diff --git a/Codec/Picture.hs b/Codec/Picture.hs deleted file mode 100644 --- a/Codec/Picture.hs +++ /dev/null @@ -1,226 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE CPP #-} --- | Main module for image import/export into various image formats. --- --- To use the library without thinking about it, look after 'decodeImage' and --- 'readImage'. --- --- Generally, the read* functions read the images from a file and try to decode --- it, and the decode* functions try to decode a bytestring. --- --- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage' --- functions -module Codec.Picture ( - -- * Generic functions - readImage - , decodeImage - , pixelMap - , generateImage - , generateFoldImage - , withImage - - -- * Generic image writing - , saveBmpImage - , saveJpgImage - , savePngImage - , saveTiffImage - , saveRadianceImage - - -- * Specific image format functions - -- ** Bitmap handling - , BmpEncodable - , writeBitmap - , encodeBitmap - , readBitmap - , decodeBitmap - , encodeDynamicBitmap - , writeDynamicBitmap - - -- ** Gif handling - , readGif - , readGifImages - , decodeGif - , decodeGifImages - - -- ** Jpeg handling - , readJpeg - , decodeJpeg - , encodeJpeg - , encodeJpegAtQuality - - -- ** Png handling - , PngSavable( .. ) - , readPng - , decodePng - , writePng - , encodeDynamicPng - , writeDynamicPng - - -- ** Tiff handling - , readTiff - , TiffSaveable - , decodeTiff - , encodeTiff - , writeTiff - - -- ** HDR (Radiance/RGBE) handling - , readHDR - , decodeHDR - , encodeHDR - , writeHDR - - -- * Image types and pixel types - -- ** Image - , Image( .. ) - , DynamicImage( .. ) - -- ** Pixels - , Pixel( .. ) - -- $graph - , Pixel8 - , Pixel16 - , PixelF - - , PixelYA8( .. ) - , PixelYA16( .. ) - , PixelRGB8( .. ) - , PixelRGB16( .. ) - , PixelRGBF( .. ) - , PixelRGBA8( .. ) - , PixelRGBA16( .. ) - , PixelYCbCr8( .. ) - , PixelCMYK8( .. ) - , PixelCMYK16( .. ) - ) where - -import Control.Applicative( (<$>) ) -import Control.DeepSeq( NFData, deepseq ) -import qualified Control.Exception as Exc ( 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.Gif( decodeGif, decodeGifImages ) -import Codec.Picture.HDR( decodeHDR - , encodeHDR - , writeHDR - ) -import Codec.Picture.Tiff( decodeTiff - , TiffSaveable - , encodeTiff - , writeTiff ) -import Codec.Picture.Saving -import Codec.Picture.Types --- import System.IO ( withFile, IOMode(ReadMode) ) -#ifdef WITH_MMAP_BYTESTRING -import System.IO.MMap ( mmapFileByteString ) -#endif - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -#include "ConvGraph.hs" - --- | Return the first Right thing, accumulating error -eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b -eitherLoad v = inner "" - where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc - inner errAcc ((hdr, f) : rest) = case f v of - 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 = Exc.catch doit - (\e -> return . Left $ show (e :: Exc.IOException)) - where doit = force . decoder <$> get -#ifdef WITH_MMAP_BYTESTRING - get = mmapFileByteString path Nothing -#else - get = B.readFile path -#endif - -- 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 = 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 --- to decode in each known format and if one decoding succeed will return --- the decoded image in it's own colorspace -decodeImage :: B.ByteString -> Either String DynamicImage -decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) - ,("PNG", decodePng) - ,("Bitmap", decodeBitmap) - ,("GIF", decodeGif) - ,("HDR", decodeHDR) - ,("Tiff", decodeTiff) - ] - --- | Helper function trying to load a png file from a file on disk. -readPng :: FilePath -> IO (Either String DynamicImage) -readPng = withImageDecoder decodePng - --- | Helper function trying to load a gif file from a file on disk. -readGif :: FilePath -> IO (Either String DynamicImage) -readGif = withImageDecoder decodeGif - --- | Helper function trying to load tiff file from a file on disk. -readTiff :: FilePath -> IO (Either String DynamicImage) -readTiff = withImageDecoder decodeTiff - --- | Helper function trying to load all the images of an animated --- gif file. -readGifImages :: FilePath -> IO (Either String [Image PixelRGB8]) -readGifImages = withImageDecoder decodeGifImages - --- | 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 - --- | Try to load a .pic file. The colorspace can only be --- RGB with floating point precision. -readHDR :: FilePath -> IO (Either String DynamicImage) -readHDR = withImageDecoder decodeHDR - --- | Save an image to a '.jpg' file, will do everything it can to save an image. -saveJpgImage :: Int -> FilePath -> DynamicImage -> IO () -saveJpgImage quality path img = L.writeFile path $ imageToJpg quality img - --- | Save an image to a '.tiff' file, will do everything it can to save an image. -saveTiffImage :: FilePath -> DynamicImage -> IO () -saveTiffImage path img = L.writeFile path $ imageToTiff img - --- | Save an image to a '.hdr' file, will do everything it can to save an image. -saveRadianceImage :: FilePath -> DynamicImage -> IO () -saveRadianceImage path = L.writeFile path . imageToRadiance - --- | Save an image to a '.png' file, will do everything it can to save an image. --- For example, a simple transcoder to png --- --- > transcodeToPng :: FilePath -> FilePath -> IO () --- > transcodeToPng pathIn pathOut = do --- > eitherImg <- readImage pathIn --- > case eitherImg of --- > Left _ -> return () --- > Right img -> savePngImage pathOut img --- -savePngImage :: String -> DynamicImage -> IO () -savePngImage path img = L.writeFile path $ imageToPng img - --- | Save an image to a '.bmp' file, will do everything it can to save an image. -saveBmpImage :: String -> DynamicImage -> IO () -saveBmpImage path img = L.writeFile path $ imageToBitmap img - diff --git a/Codec/Picture/BitWriter.hs b/Codec/Picture/BitWriter.hs deleted file mode 100644 --- a/Codec/Picture/BitWriter.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# LANGUAGE Rank2Types #-} --- | This module implement helper functions to read & write data --- at bits level. -module Codec.Picture.BitWriter( BoolReader - , emptyBoolState - , BoolState - , byteAlignJpg - , getNextBitsLSBFirst - , getNextBitsMSBFirst - , getNextBitJpg - , setDecodedString - , setDecodedStringJpg - , runBoolReader - - , BoolWriteStateRef - , newWriteStateRef - , finalizeBoolWriter - , writeBits' - - , initBoolState - , initBoolStateJpg - , execBoolReader - , runBoolReaderWith - ) where - -import Data.STRef -import Control.Applicative( (<$>), (<*>) ) -import Control.Monad( when ) -import Control.Monad.ST( ST ) -import qualified Control.Monad.Trans.State.Strict as S -import Data.Word( Word8, Word32 ) -import Data.Bits( Bits, (.&.), (.|.), unsafeShiftR, unsafeShiftL ) - -import Codec.Picture.VectorByteConversion( blitVector ) -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.Vector.Storable as VS -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - --------------------------------------------------- ----- Reader --------------------------------------------------- --- | Current bit index, current value, string -data BoolState = BoolState {-# UNPACK #-} !Int - {-# UNPACK #-} !Word8 - !B.ByteString - -emptyBoolState :: BoolState -emptyBoolState = BoolState (-1) 0 B.empty - --- | Type used to read bits -type BoolReader s a = S.StateT BoolState (ST s) a - -runBoolReader :: BoolReader s a -> ST s a -runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty - -runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState) -runBoolReaderWith st action = S.runStateT action st - -execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState -execBoolReader st reader = S.execStateT reader st - -initBoolState :: B.ByteString -> BoolState -initBoolState str = case B.uncons str of - Nothing -> BoolState 0 0 B.empty - Just (v, rest) -> BoolState 0 v rest - -initBoolStateJpg :: B.ByteString -> BoolState -initBoolStateJpg str = - case B.uncons str of - Nothing -> BoolState 0 0 B.empty - Just (0xFF, rest) -> case B.uncons rest of - Nothing -> BoolState maxBound 0 B.empty - Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker - Just (_ , afterMarker) -> initBoolStateJpg afterMarker - Just (v, rest) -> BoolState 7 v rest - --- | Bitify a list of things to decode. -setDecodedString :: B.ByteString -> BoolReader s () -setDecodedString str = case B.uncons str of - Nothing -> S.put $ BoolState 0 0 B.empty - Just (v, rest) -> S.put $ BoolState 0 v rest - --- | Drop all bit until the bit of indice 0, usefull to parse restart --- marker, as they are byte aligned, but Huffman might not. -byteAlignJpg :: BoolReader s () -byteAlignJpg = do - BoolState idx _ chain <- S.get - when (idx /= 7) (setDecodedStringJpg chain) - -{-# INLINE getNextBitJpg #-} -getNextBitJpg :: BoolReader s Bool -getNextBitJpg = do - BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 - if idx == 0 - then setDecodedStringJpg chain - else S.put $ BoolState (idx - 1) v chain - return val - -{-# INLINE getNextBitMSB #-} -getNextBitMSB :: BoolReader s Bool -getNextBitMSB = do - BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0 - if idx == 7 - then setDecodedString chain - else S.put $ BoolState (idx + 1) v chain - return val - -{-# INLINE getNextBitsMSBFirst #-} -getNextBitsMSBFirst :: Int -> BoolReader s Word32 -getNextBitsMSBFirst count = aux 0 count - where aux acc 0 = return acc - aux acc n = do - bit <- getNextBitMSB - let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1 - | otherwise = acc `unsafeShiftL` 1 - aux nextVal (n - 1) - -{-# INLINE getNextBitsLSBFirst #-} -getNextBitsLSBFirst :: Int -> BoolReader s Word32 -getNextBitsLSBFirst count = aux 0 count - where aux acc 0 = return acc - aux acc n = do - bit <- getNextBit - let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n)) - | otherwise = acc - aux nextVal (n - 1) - -{-# INLINE getNextBit #-} -getNextBit :: BoolReader s Bool -getNextBit = do - BoolState idx v chain <- S.get - let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 - if idx == 7 - then setDecodedString chain - else S.put $ BoolState (idx + 1) v chain - return val - --- | Bitify a list of things to decode. Handle Jpeg escape --- code (0xFF 0x00), thus should be only used in JPEG decoding. -setDecodedStringJpg :: B.ByteString -> BoolReader s () -setDecodedStringJpg str = case B.uncons str of - Nothing -> S.put $ BoolState maxBound 0 B.empty - Just (0xFF, rest) -> case B.uncons rest of - Nothing -> S.put $ BoolState maxBound 0 B.empty - Just (0x00, afterMarker) -> -- trace "00" $ - S.put $ BoolState 7 0xFF afterMarker - Just (_ , afterMarker) -> setDecodedStringJpg afterMarker - Just (v, rest) -> - S.put $ BoolState 7 v rest - --------------------------------------------------- ----- Writer --------------------------------------------------- -defaultBufferSize :: Int -defaultBufferSize = 256 * 1024 - -data BoolWriteStateRef s = BoolWriteStateRef - { bwsCurrBuffer :: STRef s (M.MVector s Word8) - , bwsBufferList :: STRef s [B.ByteString] - , bwsWrittenWords :: STRef s Int - , bwsBitAcc :: STRef s Word8 - , bwsBitReaded :: STRef s Int - } - -newWriteStateRef :: ST s (BoolWriteStateRef s) -newWriteStateRef = do - origMv <- M.new defaultBufferSize - BoolWriteStateRef <$> newSTRef origMv - <*> newSTRef [] - <*> newSTRef 0 - <*> newSTRef 0 - <*> newSTRef 0 - -finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString -finalizeBoolWriter st = do - forceBufferFlushing' st - L.fromChunks <$> readSTRef (bwsBufferList st) - -forceBufferFlushing' :: BoolWriteStateRef s -> ST s () -forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef - , bwsWrittenWords = countRef - , bwsBufferList = lstRef - }) = do - vec <- readSTRef vecRef - count <- readSTRef countRef - lst <- readSTRef lstRef - - nmv <- M.new defaultBufferSize - str <- byteStringFromVector vec count - - writeSTRef vecRef nmv - writeSTRef lstRef $ lst ++ [str] - writeSTRef countRef 0 - -flushCurrentBuffer' :: BoolWriteStateRef s -> ST s () -flushCurrentBuffer' st = do - count <- readSTRef $ bwsWrittenWords st - when (count >= defaultBufferSize) - (forceBufferFlushing' st) - -byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString -byteStringFromVector vec size = do - frozen <- VS.unsafeFreeze vec - return $ blitVector frozen 0 size - -setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s () -{-# INLINE setBitCount' #-} -setBitCount' st acc count = do - writeSTRef (bwsBitAcc st) acc - writeSTRef (bwsBitReaded st) count - -resetBitCount' :: BoolWriteStateRef s -> ST s () -{-# INLINE resetBitCount' #-} -resetBitCount' st = setBitCount' st 0 0 - -pushByte' :: BoolWriteStateRef s -> Word8 -> ST s () -{-# INLINE pushByte' #-} -pushByte' st v = do - flushCurrentBuffer' st - idx <- readSTRef (bwsWrittenWords st) - vec <- readSTRef (bwsCurrBuffer st) - M.write vec idx v - writeSTRef (bwsWrittenWords st) $ idx + 1 - --- | Append some data bits to a Put monad. -writeBits' :: BoolWriteStateRef s - -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB - -> Int -- ^ Number of bit to write from 1 to 32 - -> ST s () -{-# INLINE writeBits' #-} -writeBits' st d c = do - currWord <- readSTRef $ bwsBitAcc st - currCount <- readSTRef $ bwsBitReaded st - serialize d c currWord currCount - where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00 - dumpByte i = pushByte' st i - - serialize bitData bitCount currentWord count - | bitCount + count == 8 = do - resetBitCount' st - dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|. - fromIntegral cleanData) - - | bitCount + count < 8 = - let newVal = currentWord `unsafeShiftL` bitCount - in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount - - | otherwise = - let leftBitCount = 8 - count :: Int - highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32 - prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32 - - nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32 - newData = cleanData .&. nextMask :: Word32 - newCount = bitCount - leftBitCount :: Int - - toWrite = fromIntegral $ prevPart .|. highPart :: Word8 - in dumpByte toWrite >> serialize newData newCount 0 0 - - where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 - cleanData = bitData .&. cleanMask :: Word32 - diff --git a/Codec/Picture/Bitmap.hs b/Codec/Picture/Bitmap.hs deleted file mode 100644 --- a/Codec/Picture/Bitmap.hs +++ /dev/null @@ -1,350 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} --- | Modules used for Bitmap file (.bmp) file loading and writing -module Codec.Picture.Bitmap( -- * Functions - writeBitmap - , encodeBitmap - , decodeBitmap - , encodeDynamicBitmap - , writeDynamicBitmap - -- * Accepted formt in output - , BmpEncodable( ) - ) where -import Control.Monad( when, forM_ ) -import Control.Monad.ST ( ST, runST ) -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M -import Data.Binary( Binary( .. ) ) -import Data.Binary.Put( Put - , runPut - , putWord16le - , putWord32le - , putByteString - ) - -import Data.Binary.Get( Get - , getWord16le - , getWord32le - , bytesRead - , skip - ) - -import Data.Word( Word32, Word16, Word8 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.VectorByteConversion - -data BmpHeader = BmpHeader - { magicIdentifier :: !Word16 - , fileSize :: !Word32 -- ^ in bytes - , reserved1 :: !Word16 - , reserved2 :: !Word16 - , dataOffset :: !Word32 - } - -bitmapMagicIdentifier :: Word16 -bitmapMagicIdentifier = 0x4D42 - -instance Binary BmpHeader where - put hdr = do - putWord16le $ magicIdentifier hdr - putWord32le $ fileSize hdr - putWord16le $ reserved1 hdr - putWord16le $ reserved2 hdr - putWord32le $ dataOffset hdr - - get = do - ident <- getWord16le - when (ident /= bitmapMagicIdentifier) - (fail "Invalid Bitmap magic identifier") - fsize <- getWord32le - r1 <- getWord16le - r2 <- getWord16le - offset <- getWord32le - return BmpHeader - { magicIdentifier = ident - , fileSize = fsize - , reserved1 = r1 - , reserved2 = r2 - , dataOffset = offset - } - - -data BmpInfoHeader = BmpInfoHeader - { size :: !Word32 -- Header size in bytes - , width :: !Word32 - , height :: !Word32 - , planes :: !Word16 -- Number of colour planes - , bitPerPixel :: !Word16 - , bitmapCompression :: !Word32 - , byteImageSize :: !Word32 - , xResolution :: !Word32 -- ^ Pixels per meter - , yResolution :: !Word32 -- ^ Pixels per meter - , colorCount :: !Word32 - , importantColours :: !Word32 - } - -sizeofBmpHeader, sizeofBmpInfo :: Word32 -sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 -sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 - -instance Binary BmpInfoHeader where - put hdr = do - putWord32le $ size hdr - putWord32le $ width hdr - putWord32le $ height hdr - putWord16le $ planes hdr - putWord16le $ bitPerPixel hdr - putWord32le $ bitmapCompression hdr - putWord32le $ byteImageSize hdr - putWord32le $ xResolution hdr - putWord32le $ yResolution hdr - putWord32le $ colorCount hdr - putWord32le $ importantColours hdr - - get = do - readSize <- getWord32le - readWidth <- getWord32le - readHeight <- getWord32le - readPlanes <- getWord16le - readBitPerPixel <- getWord16le - readBitmapCompression <- getWord32le - readByteImageSize <- getWord32le - readXResolution <- getWord32le - readYResolution <- getWord32le - readColorCount <- getWord32le - readImportantColours <- getWord32le - return BmpInfoHeader { - size = readSize, - width = readWidth, - height = readHeight, - planes = readPlanes, - bitPerPixel = readBitPerPixel, - bitmapCompression = readBitmapCompression, - byteImageSize = readByteImageSize, - xResolution = readXResolution, - yResolution = readYResolution, - colorCount = readColorCount, - importantColours = readImportantColours - } - -newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)] - -putPalette :: BmpPalette -> Put -putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p - --- | All the instance of this class can be written as a bitmap file --- using this library. -class BmpEncodable pixel where - bitsPerPixel :: pixel -> Int - bmpEncode :: Image pixel -> Put - defaultPalette :: pixel -> BmpPalette - defaultPalette _ = BmpPalette [] - -stridePut :: M.STVector s Word8 -> Int -> Int -> ST s () -{-# INLINE stridePut #-} -stridePut vec = inner - where inner _ 0 = return () - inner ix n = do - (vec `M.unsafeWrite` ix) 0 - inner (ix + 1) (n - 1) - -instance BmpEncodable Pixel8 where - defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]] - bitsPerPixel _ = 8 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = - forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l - where stride = fromIntegral $ linePadding 8 w - putVector vec = putByteString $ blitVector vec 0 lineWidth - lineWidth = w + stride - - encodeLine line = do - buff <- M.new lineWidth - - let lineIdx = line * w - inner col | col >= w = return () - inner col = do - let v = (arr `V.unsafeIndex` (lineIdx + col)) - (buff `M.unsafeWrite` col) v - inner (col + 1) - - inner 0 - - stridePut buff w stride - V.unsafeFreeze buff - -instance BmpEncodable PixelRGBA8 where - bitsPerPixel _ = 32 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = - forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l - where putVector vec = putByteString . blitVector vec 0 $ w * 4 - putLine line = do - buff <- M.new $ 4 * w - let initialIndex = line * w * 4 - inner col _ _ | col >= w = return () - inner col writeIdx readIdx = do - let r = arr `V.unsafeIndex` readIdx - g = arr `V.unsafeIndex` (readIdx + 1) - b = arr `V.unsafeIndex` (readIdx + 2) - a = arr `V.unsafeIndex` (readIdx + 3) - - (buff `M.unsafeWrite` writeIdx) b - (buff `M.unsafeWrite` (writeIdx + 1)) g - (buff `M.unsafeWrite` (writeIdx + 2)) r - (buff `M.unsafeWrite` (writeIdx + 3)) a - - inner (col + 1) (writeIdx + 4) (readIdx + 4) - - inner 0 0 initialIndex - V.unsafeFreeze buff - -instance BmpEncodable PixelRGB8 where - bitsPerPixel _ = 24 - bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = - forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l - where stride = fromIntegral . linePadding 24 $ w - putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride) - putLine line = do - buff <- M.new $ w * 3 + stride - let initialIndex = line * w * 3 - inner col _ _ | col >= w = return () - inner col writeIdx readIdx = do - let r = (arr `V.unsafeIndex` readIdx) - g = (arr `V.unsafeIndex` (readIdx + 1)) - b = (arr `V.unsafeIndex` (readIdx + 2)) - - (buff `M.unsafeWrite` writeIdx) b - (buff `M.unsafeWrite` (writeIdx + 1)) g - (buff `M.unsafeWrite` (writeIdx + 2)) r - - inner (col + 1) (writeIdx + 3) (readIdx + 3) - - inner 0 0 initialIndex - V.unsafeFreeze buff - -decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 -decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray - where wi = fromIntegral w - hi = fromIntegral h - stArray = runST $ do - arr <- M.new (fromIntegral $ w * h * 3) - forM_ [hi - 1, hi - 2 .. 0] (readLine arr) - V.unsafeFreeze arr - - stride = linePadding 24 wi - readLine arr line = - let readIndex = (wi * 3 + stride) * line - lastIndex = wi * (hi - 1 - line + 1) * 3 - writeIndex = wi * (hi - 1 - line) * 3 - - inner _ writeIdx | writeIdx >= lastIndex = return () - inner readIdx writeIdx = do - (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + 2)) - (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1)) - (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` readIdx) - inner (readIdx + 3) (writeIdx + 3) - - in inner readIndex writeIndex - - --- | Try to decode a bitmap image. --- Right now this function can output the following pixel types : --- --- * PixelRGB8 --- -decodeBitmap :: B.ByteString -> Either String DynamicImage -decodeBitmap str = flip runGetStrict str $ do - hdr <- get :: Get BmpHeader - bmpHeader <- get :: Get BmpInfoHeader - case (bitPerPixel bmpHeader, planes bmpHeader, - bitmapCompression bmpHeader) of - -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" - (24, 1, 0) -> do - readed <- bytesRead - - when (readed > fromIntegral (dataOffset hdr)) - (fail "Invalid bmp image, data in header") - - skip . fromIntegral $ dataOffset hdr - fromIntegral readed - rest <- getRemainingBytes - return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest - a -> fail $ "Can't handle BMP file " ++ show a - - --- | Write an image in a file use the bitmap format. -writeBitmap :: (BmpEncodable pixel) - => FilePath -> Image pixel -> IO () -writeBitmap filename img = L.writeFile filename $ encodeBitmap img - -linePadding :: Int -> Int -> Int -linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 - where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8) - --- | Encode an image into a bytestring in .bmp format ready to be written --- on disk. -encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString -encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) - - --- | Write a dynamic image in a .bmp image file if possible. --- The same restriction as encodeDynamicBitmap apply. -writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) -writeDynamicBitmap path img = case encodeDynamicBitmap img of - Left err -> return $ Left err - Right b -> L.writeFile path b >> return (Right True) - --- | Encode a dynamic image in bmp if possible, supported pixel type are : --- --- - RGB8 --- --- - RGBA8 --- --- - Y8 --- -encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString -encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img -encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img -encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img -encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" - - --- | Convert an image to a bytestring ready to be serialized. -encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) - => BmpPalette -> Image pixel -> L.ByteString -encodeBitmapWithPalette pal@(BmpPalette palette) img = - runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img - where imgWidth = fromIntegral $ imageWidth img - imgHeight = fromIntegral $ imageHeight img - - paletteSize = fromIntegral $ length palette - bpp = bitsPerPixel (undefined :: pixel) - padding = linePadding bpp (imgWidth + 1) - imagePixelSize = fromIntegral $ (imgWidth + padding) * imgHeight * 4 - hdr = BmpHeader { - magicIdentifier = bitmapMagicIdentifier, - fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize, - reserved1 = 0, - reserved2 = 0, - dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize - } - - info = BmpInfoHeader { - size = sizeofBmpInfo, - width = fromIntegral imgWidth, - height = fromIntegral imgHeight, - planes = 1, - bitPerPixel = fromIntegral bpp, - bitmapCompression = 0, -- no compression - byteImageSize = imagePixelSize, - xResolution = 0, - yResolution = 0, - colorCount = 0, - importantColours = paletteSize - } - - diff --git a/Codec/Picture/ConvGraph.hs b/Codec/Picture/ConvGraph.hs deleted file mode 100644 --- a/Codec/Picture/ConvGraph.hs +++ /dev/null @@ -1,9 +0,0 @@ --- $graph --- --- The following graph describe the differents way to convert between pixel types, --- --- * Nodes describe pixel type --- --- * Arrows describe functions --- --- <> diff --git a/Codec/Picture/Gif.hs b/Codec/Picture/Gif.hs deleted file mode 100644 --- a/Codec/Picture/Gif.hs +++ /dev/null @@ -1,380 +0,0 @@ --- | Module implementing GIF decoding. -module Codec.Picture.Gif ( decodeGif - , decodeGifImages - ) where - -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( replicateM ) -import Control.Monad.ST( runST ) -import Control.Monad.Trans.Class( lift ) - -import Data.Bits( (.&.), unsafeShiftR, testBit ) -import Data.Word( Word8, Word16 ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -import Data.Binary( Binary(..) ) -import Data.Binary.Get( Get - , getWord8 - , getWord16le - , getByteString - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.BitWriter - -{- - ::= Header * Trailer - - ::= Logical Screen Descriptor [Global Color Table] - - ::= | - - - ::= [Graphic Control Extension] - - ::= | - Plain Text Extension - - ::= Image Descriptor [Local Color Table] Image Data - - ::= Application Extension | - Comment Extension - -} - --------------------------------------------------- ----- GifVersion --------------------------------------------------- -data GifVersion = GIF87a | GIF89a - -gif87aSignature, gif89aSignature :: B.ByteString -gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" -gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" - -instance Binary GifVersion where - put GIF87a = put gif87aSignature - put GIF89a = put gif89aSignature - - get = do - sig <- getByteString (B.length gif87aSignature) - case (sig == gif87aSignature, sig == gif89aSignature) of - (True, _) -> pure GIF87a - (_ , True) -> pure GIF89a - _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) - - --------------------------------------------------- ----- LogicalScreenDescriptor --------------------------------------------------- --- | Section 18 of spec-gif89a -data LogicalScreenDescriptor = LogicalScreenDescriptor - { -- | Stored on 16 bits - screenWidth :: !Word16 - -- | Stored on 16 bits - , screenHeight :: !Word16 - -- | Stored on 8 bits - , backgroundIndex :: !Word8 - - -- | Stored on 1 bit - , hasGlobalMap :: !Bool - -- | Stored on 3 bits - , colorResolution :: !Word8 - -- | Stored on 1 bit - , isColorTableSorted :: !Bool - -- | Stored on 3 bits - , colorTableSize :: !Word8 - } - -instance Binary LogicalScreenDescriptor where - put _ = undefined - get = do - w <- getWord16le - h <- getWord16le - packedField <- getWord8 - backgroundColorIndex <- getWord8 - _aspectRatio <- getWord8 - return LogicalScreenDescriptor - { screenWidth = w - , screenHeight = h - , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 - , isColorTableSorted = packedField `testBit` 3 - , colorTableSize = (packedField .&. 0x7) + 1 - , backgroundIndex = backgroundColorIndex - } - - --------------------------------------------------- ----- ImageDescriptor --------------------------------------------------- --- | Section 20 of spec-gif89a -data ImageDescriptor = ImageDescriptor - { gDescPixelsFromLeft :: !Word16 - , gDescPixelsFromTop :: !Word16 - , gDescImageWidth :: !Word16 - , gDescImageHeight :: !Word16 - , gDescHasLocalMap :: !Bool - , gDescIsInterlaced :: !Bool - , gDescIsImgDescriptorSorted :: !Bool - , gDescLocalColorTableSize :: !Word8 - } - -imageSeparator, extensionIntroducer, gifTrailer :: Word8 -imageSeparator = 0x2C -extensionIntroducer = 0x21 -gifTrailer = 0x3B - -graphicControlLabel :: Word8 -graphicControlLabel = 0xF9 - ---commentLabel, graphicControlLabel, applicationLabel --- -{-commentLabel = 0xFE-} -{-plainTextLabel = 0x01-} -{-applicationLabel = 0xFF-} - -parseDataBlocks :: Get B.ByteString -parseDataBlocks = B.concat <$> (getWord8 >>= aux) - where aux 0 = pure [] - aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) - -data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !Word8 -- ^ Stored on 3 bits - , gceUserInputFlag :: !Bool - , gceTransparentFlag :: !Bool - , gceDelay :: !Word16 - , gceTransparentColorIndex :: !Word8 - } - -instance Binary GraphicControlExtension where - put _ = undefined - get = do - -- due to missing lookahead - {-_extensionLabel <- getWord8-} - _size <- getWord8 - packedFields <- getWord8 - delay <- getWord16le - idx <- getWord8 - _blockTerminator <- getWord8 - return GraphicControlExtension - { gceDisposalMethod = (packedFields `unsafeShiftR` 2) .&. 0x07 - , gceUserInputFlag = packedFields `testBit` 1 - , gceTransparentFlag = packedFields `testBit` 0 - , gceDelay = delay - , gceTransparentColorIndex = idx - } - -data GifImage = GifImage - { imgDescriptor :: !ImageDescriptor - , imgLocalPalette :: !(Maybe Palette) - , imgLzwRootSize :: !Word8 - , imgData :: B.ByteString - } - -instance Binary GifImage where - put _ = undefined - get = do - desc <- get - let hasLocalColorTable = gDescHasLocalMap desc - palette <- if hasLocalColorTable - then Just <$> getPalette (gDescLocalColorTableSize desc) - else pure Nothing - - GifImage desc palette <$> getWord8 <*> parseDataBlocks - -data Block = BlockImage GifImage - | BlockGraphicControl GraphicControlExtension - -parseGifBlocks :: Get [Block] -parseGifBlocks = getWord8 >>= blockParse - where blockParse v - | v == gifTrailer = pure [] - | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks - | v == extensionIntroducer = do - extensionCode <- getWord8 - if extensionCode /= graphicControlLabel - then parseDataBlocks >> parseGifBlocks - else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks - - blockParse v = do - fail ("Unrecognized gif block " ++ show v) - -instance Binary ImageDescriptor where - put _ = undefined - get = do - -- due to missing lookahead - {-_imageSeparator <- getWord8-} - imgLeftPos <- getWord16le - imgTopPos <- getWord16le - imgWidth <- getWord16le - imgHeight <- getWord16le - packedFields <- getWord8 - let tableSize = packedFields .&. 0x7 - return ImageDescriptor - { gDescPixelsFromLeft = imgLeftPos - , gDescPixelsFromTop = imgTopPos - , gDescImageWidth = imgWidth - , gDescImageHeight = imgHeight - , gDescHasLocalMap = packedFields `testBit` 7 - , gDescIsInterlaced = packedFields `testBit` 6 - , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 - } - - --------------------------------------------------- ----- Palette --------------------------------------------------- -type Palette = Image PixelRGB8 - -getPalette :: Word8 -> Get Palette -getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList - where size = 2 ^ (fromIntegral bitDepth :: Int) - --------------------------------------------------- ----- GifImage --------------------------------------------------- -data GifHeader = GifHeader - { gifVersion :: GifVersion - , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette - } - -instance Binary GifHeader where - put _ = undefined - get = do - version <- get - screenDesc <- get - palette <- getPalette $ colorTableSize screenDesc - return GifHeader - { gifVersion = version - , gifScreenDescriptor = screenDesc - , gifGlobalMap = palette - } - -data GifFile = GifFile - { gifHeader :: !GifHeader - , gifImages :: [(Maybe GraphicControlExtension, GifImage)] - } - -associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] -associateDescr [] = [] -associateDescr [BlockGraphicControl _] = [] -associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest -associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs -associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = - (Just ctrl, img) : associateDescr xs - -instance Binary GifFile where - put _ = undefined - get = do - hdr <- get - blocks <- parseGifBlocks - return GifFile { gifHeader = hdr - , gifImages = associateDescr blocks } - -substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 -substituteColors palette = pixelMap swaper - where swaper n = pixelAt palette (fromIntegral n) 0 - -decodeImage :: GifImage -> Image Pixel8 -decodeImage img = runST $ runBoolReader $ do - outputVector <- lift . M.new $ width * height - decodeLzw (imgData img) 12 lzwRoot outputVector - frozenData <- lift $ V.unsafeFreeze outputVector - return . deinterlaceGif $ Image - { imageWidth = width - , imageHeight = height - , imageData = frozenData - } - where lzwRoot = fromIntegral $ imgLzwRootSize img - width = fromIntegral $ gDescImageWidth descriptor - height = fromIntegral $ gDescImageHeight descriptor - isInterlaced = gDescIsInterlaced descriptor - descriptor = imgDescriptor img - - deinterlaceGif | not isInterlaced = id - | otherwise = deinterlaceGifImage - -deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 -deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h - where lineIndices = gifInterlacingIndices h - generator x y = pixelAt img x y' - where y' = lineIndices V.! y - -gifInterlacingIndices :: Int -> V.Vector Int -gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices - where indices = flip zip [0..] $ - concat [ [0, 8 .. height - 1] - , [4, 4 + 8 .. height - 1] - , [2, 2 + 4 .. height - 1] - , [1, 1 + 2 .. height - 1] - ] - -paletteOf :: Palette -> GifImage -> Palette -paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = p - -decodeAllGifImages :: GifFile -> [Image PixelRGB8] -decodeAllGifImages GifFile { gifImages = [] } = [] -decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor - } - , gifImages = (_, firstImage) : rest } = map paletteApplyer $ - scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest - where globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor - - {-background = backgroundIndex wholeDescriptor-} - - paletteApplyer (pal, img) = substituteColors pal img - - generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (paletteOf palette img2, generateImage pixeler globalWidth globalHeight) - where localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor - - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor - - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight - - decoded = decodeImage img2 - - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 - - pixeler x y - | isPixelInLocalImage x y && fromIntegral val /= transparent = val - where val = pixelAt decoded (x - left) (y - top) - pixeler x y = pixelAt img1 x y - -decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) -decodeFirstGifImage - GifFile { gifHeader = GifHeader { gifGlobalMap = palette} - , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif -decodeFirstGifImage _ = Left "No image in gif file" - --- | Transform a raw gif image to an image, witout --- modifying the pixels. --- This function can output the following pixel types : --- --- * PixelRGB8 --- -decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage) - --- | Transform a raw gif to a list of images, representing --- all the images of an animation. -decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] -decodeGifImages img = decodeAllGifImages <$> decode img - diff --git a/Codec/Picture/Gif/LZW.hs b/Codec/Picture/Gif/LZW.hs deleted file mode 100644 --- a/Codec/Picture/Gif/LZW.hs +++ /dev/null @@ -1,189 +0,0 @@ -module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where - -import Data.Word( Word8 ) -import Control.Applicative( (<$>) ) -import Control.Monad( when ) - -import Data.Bits( (.&.) ) - -import Control.Monad.ST( ST ) -import Control.Monad.Trans.Class( MonadTrans, lift ) - -import Foreign.Storable ( Storable ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a -(.!!!.) = M.unsafeRead - {-M.read-} - -{-# INLINE (..!!!..) #-} -(..!!!..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> t (ST s) a -(..!!!..) v idx = lift $ v .!!!. idx - -{-# INLINE (.<-.) #-} -(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () -(.<-.) = M.unsafeWrite - {-M.write-} - -{-# INLINE (..<-..) #-} -(..<-..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> a -> t (ST s) () -(..<-..) v idx = lift . (v .<-. idx) - - -duplicateData :: (Show a, MonadTrans t, Storable a) - => M.STVector s a -> M.STVector s a - -> Int -> Int -> Int -> t (ST s) () -duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex - where endIndex = sourceIndex + size - aux i _ | i == endIndex = return () - aux i j = do - src .!!!. i >>= (dest .<-. j) - aux (i + 1) (j + 1) - -rangeSetter :: (Storable a, Num a) - => Int -> M.STVector s a - -> ST s (M.STVector s a) -rangeSetter count vec = aux 0 - where aux n | n == count = return vec - aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) - -decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -decodeLzw str maxBitKey initialKey outVec = do - setDecodedString str - lzw GifVariant maxBitKey initialKey 0 outVec - -isOldTiffLZW :: B.ByteString -> Bool -isOldTiffLZW str = firstByte == 0 && secondByte == 1 - where firstByte = str `B.index` 0 - secondByte = (str `B.index` 1) .&. 1 - -decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int - -> BoolReader s() -decodeLzwTiff str outVec initialWriteIdx = do - setDecodedString str - let variant | isOldTiffLZW str = OldTiffVariant - | otherwise = TiffVariant - lzw variant 12 9 initialWriteIdx outVec - -data TiffVariant = - GifVariant - | TiffVariant - | OldTiffVariant - deriving Eq - --- | Gif image constraint from spec-gif89a, code size max : 12 bits. -lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do - -- Allocate buffer of maximum size. - lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray - lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray - lzwSizeTable <- lift $ M.replicate tableEntryCount 0 - lift $ lzwSizeTable `M.set` 1 - - let firstVal code = do - dataOffset <- lzwOffsetTable ..!!!.. code - lzwData ..!!!.. dataOffset - - writeString at code = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (at + dataSize <= maxWrite) $ - duplicateData lzwData outVec dataOffset dataSize at - - return dataSize - - addString pos at code val = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (pos < tableEntryCount) $ do - (lzwOffsetTable ..<-.. pos) at - (lzwSizeTable ..<-.. pos) $ dataSize + 1 - - when (at + dataSize + 1 <= maxDataSize) $ do - duplicateData lzwData lzwData dataOffset dataSize at - (lzwData ..<-.. (at + dataSize)) val - - return $ dataSize + 1 - - maxWrite = M.length outVec - loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code - | outWriteIdx >= maxWrite = return () - | code == endOfInfo = return () - | code == clearCode = do - toOutput <- getNextCode startCodeSize - if toOutput == endOfInfo then - return () - else do - dataSize <- writeString outWriteIdx toOutput - getNextCode startCodeSize >>= - loop (outWriteIdx + dataSize) - firstFreeIndex firstFreeIndex startCodeSize toOutput - - | otherwise = do - (written, dicAdd) <- - if code >= writeIdx then do - c <- firstVal oldCode - wroteSize <- writeString outWriteIdx oldCode - (outVec ..<-.. (outWriteIdx + wroteSize)) c - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize + 1, addedSize) - else do - wroteSize <- writeString outWriteIdx code - c <- firstVal code - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize, addedSize) - - let new_code_size = updateCodeSize codeSize $ writeIdx + 1 - getNextCode new_code_size >>= - loop (outWriteIdx + written) - (writeIdx + 1) - (dicWriteIdx + dicAdd) - new_code_size - code - - getNextCode startCodeSize >>= - loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 - - where tableEntryCount = 2 ^ min 12 nMaxBitKeySize - maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 - - isNewTiff = variant == TiffVariant - (switchOffset, isTiffVariant) = case variant of - GifVariant -> (0, False) - TiffVariant -> (1, True) - OldTiffVariant -> (0, True) - - initialElementCount = 2 ^ initialKeySize :: Int - clearCode | isTiffVariant = 256 - | otherwise = initialElementCount - - endOfInfo | isTiffVariant = 257 - | otherwise = clearCode + 1 - - startCodeSize - | isTiffVariant = initialKeySize - | otherwise = initialKeySize + 1 - - firstFreeIndex = endOfInfo + 1 - - resetArray a = lift $ rangeSetter initialElementCount a - - updateCodeSize codeSize writeIdx - | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 - | otherwise = codeSize - - getNextCode s - | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s - | otherwise = fromIntegral <$> getNextBitsLSBFirst s - diff --git a/Codec/Picture/HDR.hs b/Codec/Picture/HDR.hs deleted file mode 100644 --- a/Codec/Picture/HDR.hs +++ /dev/null @@ -1,462 +0,0 @@ --- | Module dedicated of Radiance file decompression (.hdr or .pic) file. --- Radiance file format is used for High dynamic range imaging. -module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where - -import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) -import Data.Char( ord, chr, isDigit ) -import Data.Word( Word8 ) -import Data.Monoid( (<>) ) -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( when, foldM, foldM_, forM, forM_ ) -import Control.Monad.Trans.Class( lift ) -import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Char8 as BC - -import Data.List( partition ) -import Data.Binary( Binary( .. ), encode ) -import Data.Binary.Get( Get, getByteString, getWord8 ) -import Data.Binary.Put( putByteString, putLazyByteString ) - -import Control.Monad.ST( ST, runST ) -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 Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.VectorByteConversion - -{-# INLINE (.<<.) #-} -(.<<.), (.>>.) :: (Bits a) => a -> Int -> a -(.<<.) = unsafeShiftL -(.>>.) = unsafeShiftR - -{-# INLINE (.<-.) #-} -(.<-.) :: (PrimMonad m, Storable a) - => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.write - {-M.unsafeWrite-} - -type HDRReader s a = ErrorT String (ST s) a - -data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 - -instance Binary RGBE where - put (RGBE r g b e) = put r >> put g >> put b >> put e - get = RGBE <$> get <*> get <*> get <*> get - -checkLineLength :: RGBE -> Int -checkLineLength (RGBE _ _ a b) = - (fromIntegral a .<<. 8) .|. fromIntegral b - -isNewRunLengthMarker :: RGBE -> Bool -isNewRunLengthMarker (RGBE 2 2 _ _) = True -isNewRunLengthMarker _ = False - -data RadianceFormat = - FormatRGBE - | FormatXYZE - -radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString -radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" -radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" - -instance Binary RadianceFormat where - put FormatRGBE = putByteString radiance32bitRleRGBEFormat - put FormatXYZE = putByteString radiance32bitRleXYZEFromat - - get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format - where format sig - | sig == radiance32bitRleRGBEFormat = pure FormatRGBE - | sig == radiance32bitRleXYZEFromat = pure FormatXYZE - | otherwise = fail "Unrecognized Radiance format" - -toRGBE :: PixelRGBF -> RGBE -toRGBE (PixelRGBF r g b) - | d <= 1e-32 = RGBE 0 0 0 0 - | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) - where d = maximum [r, g, b] - e = exponent d - coeff = significand d * 255.9999 / d - fix v = truncate $ v * coeff - - -dropUntil :: Word8 -> Get () -dropUntil c = getWord8 >>= inner - where inner val | val == c = pure () - inner _ = getWord8 >>= inner - -getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString -getUntil f initialAcc = getWord8 >>= inner initialAcc - where inner acc c | f c = pure acc - inner acc c = getWord8 >>= inner (B.snoc acc c) - -data RadianceHeader = RadianceHeader - { radianceInfos :: [(B.ByteString, B.ByteString)] - , radianceFormat :: RadianceFormat - , radianceHeight :: !Int - , radianceWidth :: !Int - , radianceData :: L.ByteString - } - -radianceFileSignature :: B.ByteString -radianceFileSignature = BC.pack "#?RADIANCE\n" - -unpackColor :: L.ByteString -> Int -> RGBE -unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) - where at n = L.index str . fromIntegral $ idx + n - -storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () -storeColor vec idx (RGBE r g b e) = do - (vec .<-. (idx + 0)) r - (vec .<-. (idx + 1)) g - (vec .<-. (idx + 2)) b - (vec .<-. (idx + 3)) e - -parsePair :: Char -> Get (B.ByteString, B.ByteString) -parsePair firstChar = do - let eol c = c == fromIntegral (ord '\n') - line <- getUntil eol B.empty - case BC.split '=' line of - [] -> pure (BC.singleton firstChar, B.empty) - [val] -> pure (BC.singleton firstChar, val) - [key, val] -> pure (BC.singleton firstChar <> key, val) - (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) - -decodeInfos :: Get [(B.ByteString, B.ByteString)] -decodeInfos = do - char <- getChar8 - case char of - -- comment - '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos - -- end of header, no more information - '\n' -> pure [] - -- Classical parsing - c -> (:) <$> parsePair c <*> decodeInfos - - --- | Decode an HDR (radiance) image, the resulting pixel --- type can be : --- --- * PixelRGBF --- -decodeHDR :: B.ByteString -> Either String DynamicImage -decodeHDR str = runST $ runErrorT $ do - case runGet decodeHeader $ L.fromChunks [str] of - Left err -> throwError err - Right rez -> - ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) - -getChar8 :: Get Char -getChar8 = chr . fromIntegral <$> getWord8 - -isSign :: Char -> Bool -isSign c = c == '+' || c == '-' - -isAxisLetter :: Char -> Bool -isAxisLetter c = c == 'X' || c == 'Y' - -decodeNum :: Get Int -decodeNum = do - sign <- getChar8 - letter <- getChar8 - space <- getChar8 - - when (not $ isSign sign && isAxisLetter letter && space == ' ') - (fail "Invalid radiance size declaration") - - let numDec acc c | isDigit c = - getChar8 >>= numDec (acc * 10 + ord c - (ord '0')) - numDec acc _ - | sign == '-' = pure $ negate acc - | otherwise = pure acc - - getChar8 >>= numDec 0 - -copyPrevColor :: M.STVector s Word8 -> Int -> ST s () -copyPrevColor scanLine idx = do - r <- scanLine `M.unsafeRead` (idx - 4) - g <- scanLine `M.unsafeRead` (idx - 3) - b <- scanLine `M.unsafeRead` (idx - 2) - e <- scanLine `M.unsafeRead` (idx - 1) - - (scanLine `M.unsafeWrite` (idx + 0)) r - (scanLine `M.unsafeWrite` (idx + 1)) g - (scanLine `M.unsafeWrite` (idx + 2)) b - (scanLine `M.unsafeWrite` (idx + 3)) e - -oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 - -> HDRReader s Int -oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 - where maxOutput = M.length scanLine - maxInput = fromIntegral $ L.length inputData - - inner readIdx writeIdx _ - | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx - inner readIdx writeIdx shift = do - let color@(RGBE r g b e) = unpackColor inputData readIdx - isRun = r == 1 && g == 1 && b == 1 - - if not isRun - then do - lift $ storeColor scanLine writeIdx color - inner (readIdx + 4) (writeIdx + 4) 0 - - else do - let count = fromIntegral e .<<. shift - lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) - inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) - -newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 - -> HDRReader s Int -newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] - where dataAt idx - | fromIntegral idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")" - | otherwise = pure $ L.index inputData (fromIntegral idx) - - maxOutput = M.length scanline - maxInput = fromIntegral $ L.length inputData - stride = 4 - - - strideSet count destIndex _ | endIndex > maxOutput + stride = - throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" - where endIndex = destIndex + count * stride - strideSet count destIndex val = aux destIndex count - where aux i 0 = pure i - aux i c = do - lift $ (scanline .<-. i) val - aux (i + stride) (c - 1) - - - strideCopy _ count destIndex - | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline" - where writeEndBound = destIndex + count * stride - strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count - where aux _ j 0 = pure j - aux i j c = do - val <- dataAt i - lift $ (scanline .<-. j) val - aux (i + 1) (j + stride) (c - 1) - - inner readIdx writeIdx - | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx - inner readIdx writeIdx = do - code <- dataAt readIdx - if code > 128 - then do - let repeatCount = fromIntegral code .&. 0x7F - newVal <- dataAt $ readIdx + 1 - endIndex <- strideSet repeatCount writeIdx newVal - inner (readIdx + 2) endIndex - - else do - let iCode = fromIntegral code - endIndex <- strideCopy (readIdx + 1) iCode writeIdx - inner (readIdx + iCode + 1) endIndex - -instance Binary RadianceHeader where - get = decodeHeader - put hdr = do - putByteString radianceFileSignature - putByteString $ BC.pack "FORMAT=" - put $ radianceFormat hdr - let sizeString = - BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) - ++ " +X " ++ show (radianceWidth hdr) ++ "\n" - putByteString sizeString - putLazyByteString $ radianceData hdr - - -decodeHeader :: Get RadianceHeader -decodeHeader = do - sig <- getByteString $ B.length radianceFileSignature - when (sig /= radianceFileSignature) - (fail "Invalid radiance file signature") - - infos <- decodeInfos - let formatKey = BC.pack "FORMAT" - case partition (\(k,_) -> k /= formatKey) infos of - (_, []) -> fail "No radiance format specified" - (info, [(_, formatString)]) -> - case runGet get $ L.fromChunks [formatString] of - Left err -> fail err - Right format -> do - (n1, n2, b) <- (,,) <$> decodeNum - <*> decodeNum - <*> getRemainingBytes - return . RadianceHeader info format n1 n2 $ L.fromChunks [b] - - _ -> fail "Multiple radiance format specified" - -toFloat :: RGBE -> PixelRGBF -toFloat (RGBE r g b e) = PixelRGBF rf gf bf - where f = encodeFloat 1 $ fromIntegral e - (128 + 8) - rf = (fromIntegral r + 0.0) * f - gf = (fromIntegral g + 0.0) * f - bf = (fromIntegral b + 0.0) * f - -encodeScanlineColor :: M.STVector s Word8 - -> M.STVector s Word8 - -> Int - -> ST s Int -encodeScanlineColor vec outVec outIdx = do - val <- vec `M.unsafeRead` 0 - runLength 1 0 val 1 outIdx - where maxIndex = M.length vec - - pushRun len val at = do - (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 - (outVec `M.unsafeWrite` (at + 1)) val - return $ at + 2 - - pushData start len at = do - (outVec `M.unsafeWrite` at) $ fromIntegral len - let first = start - len - end = start - 1 - offset = at - first + 1 - forM_ [first .. end] $ \i -> do - v <- vec `M.unsafeRead` i - (outVec `M.unsafeWrite` (offset + i)) v - - return $ at + len + 1 - - -- End of scanline, empty the thing - runLength run cpy prev idx at | idx >= maxIndex = - case (run, cpy) of - (0, 0) -> pure at - (0, n) -> pushData idx n at - (n, 0) -> pushRun n prev at - (_, _) -> error "HDR - Run length algorithm is wrong" - - -- full runlength, we must write the packet - runLength r@127 _ prev idx at = do - val <- vec `M.unsafeRead` idx - pushRun r prev at >>= - runLength 1 0 val (idx + 1) - - -- full copy, we must write the packet - runLength _ c@127 _ idx at = do - val <- vec `M.unsafeRead` idx - pushData idx c at >>= - runLength 1 0 val (idx + 1) - - runLength n 0 prev idx at = do - val <- vec `M.unsafeRead` idx - case val == prev of - True -> runLength (n + 1) 0 prev (idx + 1) at - False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at - False -> do - pushRun n prev at >>= - runLength 1 0 val (idx + 1) - - runLength 0 n prev idx at = do - val <- vec `M.unsafeRead` idx - if val /= prev - then runLength 0 (n + 1) val (idx + 1) at - else do - pushData (idx - 1) (n - 1) at >>= - runLength (2 :: Int) 0 val (idx + 1) - - runLength _ _ _ _ _ = - error "HDR RLE inconsistent state" - --- | Write an High dynamic range image into a radiance --- image file on disk. -writeHDR :: FilePath -> Image PixelRGBF -> IO () -writeHDR filename img = L.writeFile filename $ encodeHDR img - --- | Encode an High dynamic range image into a radiance image --- file format. -encodeHDR :: Image PixelRGBF -> L.ByteString -encodeHDR pic = encode $ runST $ do - let w = imageWidth pic - h = imageHeight pic - - scanLineR <- M.new w :: ST s (M.STVector s Word8) - scanLineG <- M.new w - scanLineB <- M.new w - scanLineE <- M.new w - - encoded <- - forM [0 .. h - 1] $ \line -> do - buff <- M.new $ w * 4 + w `div` 127 + 2 - let columner col | col >= w = return () - columner col = do - let RGBE r g b e = toRGBE $ pixelAt pic col line - (scanLineR `M.unsafeWrite` col) r - (scanLineG `M.unsafeWrite` col) g - (scanLineB `M.unsafeWrite` col) b - (scanLineE `M.unsafeWrite` col) e - - columner (col + 1) - - columner 0 - - (buff `M.unsafeWrite` 0) 2 - (buff `M.unsafeWrite` 1) 2 - (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) - (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) - - i1 <- encodeScanlineColor scanLineR buff 4 - i2 <- encodeScanlineColor scanLineG buff i1 - i3 <- encodeScanlineColor scanLineB buff i2 - endIndex <- encodeScanlineColor scanLineE buff i3 - - (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff - - pure $ RadianceHeader - { radianceInfos = [] - , radianceFormat = FormatRGBE - , radianceHeight = h - , radianceWidth = w - , radianceData = L.fromChunks encoded - } - - -decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF)) -decodeRadiancePicture hdr = do - let width = abs $ radianceWidth hdr - height = abs $ radianceHeight hdr - packedData = radianceData hdr - - scanLine <- lift $ M.new $ width * 4 - resultBuffer <- lift $ M.new $ width * height * 3 - - let scanLineImage = MutableImage - { mutableImageWidth = width - , mutableImageHeight = 1 - , mutableImageData = scanLine - } - - finalImage = MutableImage - { mutableImageWidth = width - , mutableImageHeight = height - , mutableImageData = resultBuffer - } - - let scanLineExtractor readIdx line = do - let color = unpackColor packedData readIdx - inner | isNewRunLengthMarker color = do - let calcSize = checkLineLength color - when (calcSize /= width) - (throwError "Invalid sanline size") - pure $ \idx -> newStyleRLE packedData (idx + 4) - | otherwise = pure $ oldStyleRLE packedData - f <- inner - newRead <- f readIdx scanLine - forM_ [0 .. width - 1] $ \i -> do - -- mokay, it's a hack, but I don't want to define a - -- pixel instance of RGBE... - PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 - lift $ writePixel finalImage i line . toFloat $ RGBE r g b e - - return newRead - - foldM_ scanLineExtractor 0 [0 .. height - 1] - - return finalImage - diff --git a/Codec/Picture/InternalHelper.hs b/Codec/Picture/InternalHelper.hs deleted file mode 100644 --- a/Codec/Picture/InternalHelper.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Codec.Picture.InternalHelper ( runGet - , runGetStrict - , decode - , getRemainingBytes - , getRemainingLazyBytes ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Binary( Binary( get ) ) -import Data.Binary.Get( Get, runGetOrFail, getRemainingLazyByteString ) - -decode :: (Binary a) => B.ByteString -> Either String a -decode = runGetStrict get - -runGet :: Get a -> L.ByteString -> Either String a -runGet act = unpack . runGetOrFail act - where unpack (Left (_, _, str)) = Left str - unpack (Right (_, _, element)) = Right element - -runGetStrict :: Get a -> B.ByteString -> Either String a -runGetStrict act buffer = runGet act $ L.fromChunks [buffer] - -getRemainingBytes :: Get B.ByteString -getRemainingBytes = do - rest <- getRemainingLazyByteString - return $ case L.toChunks rest of - [] -> B.empty - [a] -> a - lst -> B.concat lst - -getRemainingLazyBytes :: Get L.ByteString -getRemainingLazyBytes = getRemainingLazyByteString - diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs deleted file mode 100644 --- a/Codec/Picture/Jpg.hs +++ /dev/null @@ -1,720 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -fspec-constr-count=5 #-} --- | Module used for JPEG file loading and writing. -module Codec.Picture.Jpg( decodeJpeg - , encodeJpegAtQuality - , encodeJpeg - - , jpgMachineStep - , JpgDecoderState( JpgDecoderState ) - ) where - -import Control.Arrow( (>>>) ) -import Control.Applicative( pure, (<$>) ) -import Control.Monad( when, forM_ ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.Trans( lift ) -import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS ) - -import Data.Bits( (.|.), unsafeShiftL ) -import Data.Int( Int16, Int32 ) -import Data.Word(Word8, Word32) -import Data.Binary( Binary(..), encode ) -import Data.STRef( newSTRef, writeSTRef, readSTRef ) - -import Data.Vector( (//) ) -import Data.Vector.Unboxed( (!) ) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Codec.Picture.InternalHelper -import Codec.Picture.BitWriter -import Codec.Picture.Types -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.Common -import Codec.Picture.Jpg.Progressive -import Codec.Picture.Jpg.DefaultTable -import Codec.Picture.Jpg.FastDct - -quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 - -> ST s (MutableMacroBlock s Int32) -quantize table block = update 0 - where update 64 = return block - update idx = do - val <- block `M.unsafeRead` idx - let q = fromIntegral (table `VS.unsafeIndex` idx) - finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division - (block `M.unsafeWrite` idx) finalValue - update $ idx + 1 - - -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 :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s () -{-# INLINE encodeInt #-} -encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss) -encodeInt st ssss n = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss) - --- | Assume the macro block is initialized with zeroes -acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16 - -> BoolReader s (MutableMacroBlock s Int16) -acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock - where parseAcCoefficient n | n >= 64 = return () - | otherwise = do - rrrrssss <- decodeRrrrSsss acTree - case rrrrssss of - ( 0, 0) -> return () - (0xF, 0) -> parseAcCoefficient (n + 16) - (rrrr, ssss) -> do - decoded <- fromIntegral <$> decodeInt ssss - lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded - parseAcCoefficient (n + rrrr + 1) - --- | Decompress a macroblock from a bitstream given the current configuration --- from the frame. -decompressMacroBlock :: HuffmanPackedTree -- ^ Tree used for DC coefficient - -> HuffmanPackedTree -- ^ Tree used for Ac coefficient - -> MacroBlock Int16 -- ^ Current quantization table - -> MutableMacroBlock s Int16 -- ^ A zigzag table, to avoid allocation - -> DcCoefficient -- ^ Previous dc value - -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16) -decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do - dcDeltaCoefficient <- dcCoefficientDecode dcTree - block <- lift createEmptyMutableMacroBlock - let neoDcCoefficient = previousDc + dcDeltaCoefficient - lift $ (block `M.unsafeWrite` 0) neoDcCoefficient - fullBlock <- acCoefficientsDecode acTree block - decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock - return (neoDcCoefficient, decodedBlock) - -pixelClamp :: Int16 -> Word8 -pixelClamp n = fromIntegral . min 255 $ max 0 n - -unpack444Y :: Int -- ^ component index - -> Int -- ^ x - -> Int -- ^ y - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpack444Y _ x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) - block = blockVert baseIdx 0 zero - where zero = 0 :: Int - baseIdx = x * dctBlockSize + y * dctBlockSize * imgWidth - - blockVert _ _ j | j >= dctBlockSize = return () - blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero - where blockHoriz _ readIdx i | i >= dctBlockSize = blockVert (writeIdx + imgWidth) readIdx $ j + 1 - blockHoriz idx readIdx i = do - val <- pixelClamp <$> (block `M.unsafeRead` readIdx) - (img `M.unsafeWrite` idx) val - blockHoriz (idx + 1) (readIdx + 1) $ i + 1 - -unpack444Ycbcr :: Int -- ^ Component index - -> Int -- ^ x - -> Int -- ^ y - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpack444Ycbcr compIdx x y - (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) - block = blockVert baseIdx 0 zero - where zero = 0 :: Int - baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx - - blockVert _ _ j | j >= dctBlockSize = return () - blockVert idx readIdx j = do - val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) - val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) - val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) - val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) - val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) - val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) - val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) - val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) - - (img `M.unsafeWrite` idx) val0 - (img `M.unsafeWrite` (idx + (3 * 1))) val1 - (img `M.unsafeWrite` (idx + (3 * 2))) val2 - (img `M.unsafeWrite` (idx + (3 * 3))) val3 - (img `M.unsafeWrite` (idx + (3 * 4))) val4 - (img `M.unsafeWrite` (idx + (3 * 5))) val5 - (img `M.unsafeWrite` (idx + (3 * 6))) val6 - (img `M.unsafeWrite` (idx + (3 * 7))) val7 - - blockVert (idx + 3 * imgWidth) (readIdx + dctBlockSize) $ j + 1 - - - {-where blockHoriz _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-} - {-blockHoriz idx readIdx i = do-} - {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -} - {-(img `M.unsafeWrite` idx) val-} - {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-} - -unpack421Ycbcr :: Int -- ^ Component index - -> Int -- ^ x - -> Int -- ^ y - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpack421Ycbcr compIdx x y - (MutableImage { mutableImageWidth = imgWidth, - mutableImageHeight = _, mutableImageData = img }) - block = blockVert baseIdx 0 zero - where zero = 0 :: Int - baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx - lineOffset = imgWidth * 3 - - blockVert _ _ j | j >= dctBlockSize = return () - blockVert idx readIdx j = do - v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) - v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) - v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) - v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) - v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) - v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) - v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) - v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) - - (img `M.unsafeWrite` idx) v0 - (img `M.unsafeWrite` (idx + 3)) v0 - - (img `M.unsafeWrite` (idx + 6 * 1)) v1 - (img `M.unsafeWrite` (idx + 6 * 1 + 3)) v1 - - (img `M.unsafeWrite` (idx + 6 * 2)) v2 - (img `M.unsafeWrite` (idx + 6 * 2 + 3)) v2 - - (img `M.unsafeWrite` (idx + 6 * 3)) v3 - (img `M.unsafeWrite` (idx + 6 * 3 + 3)) v3 - - (img `M.unsafeWrite` (idx + 6 * 4)) v4 - (img `M.unsafeWrite` (idx + 6 * 4 + 3)) v4 - - (img `M.unsafeWrite` (idx + 6 * 5)) v5 - (img `M.unsafeWrite` (idx + 6 * 5 + 3)) v5 - - (img `M.unsafeWrite` (idx + 6 * 6)) v6 - (img `M.unsafeWrite` (idx + 6 * 6 + 3)) v6 - - (img `M.unsafeWrite` (idx + 6 * 7)) v7 - (img `M.unsafeWrite` (idx + 6 * 7 + 3)) v7 - - blockVert (idx + lineOffset) (readIdx + dctBlockSize) $ j + 1 - -type Unpacker s = Int -- ^ component index - -> Int -- ^ x - -> Int -- ^ y - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () - -type JpgScripter s a = - RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a - -data JpgDecoderState = JpgDecoderState - { dcDecoderTables :: !(V.Vector HuffmanPackedTree) - , acDecoderTables :: !(V.Vector HuffmanPackedTree) - , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) - , currentRestartInterv :: !Int - , currentFrame :: Maybe JpgFrameHeader - , isProgressive :: !Bool - , maximumHorizontalResolution :: !Int - , maximumVerticalResolution :: !Int - , seenBlobs :: !Int - } - -emptyDecoderState :: JpgDecoderState -emptyDecoderState = JpgDecoderState - { dcDecoderTables = V.fromList $ map snd - [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable - , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable - ] - - , acDecoderTables = V.fromList $ map snd - [ prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable - , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable - ] - - , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1) - , currentRestartInterv = -1 - , currentFrame = Nothing - , isProgressive = False - , maximumHorizontalResolution = 0 - , maximumVerticalResolution = 0 - , seenBlobs = 0 - } - --- | This pseudo interpreter interpret the Jpg frame for the huffman, --- quant table and restart interval parameters. -jpgMachineStep :: JpgFrame -> JpgScripter s () -jpgMachineStep (JpgAppFrame _ _) = pure () -jpgMachineStep (JpgExtension _ _) = pure () -jpgMachineStep (JpgScanBlob hdr raw_data) = do - let scanCount = length $ scans hdr - params <- concat <$> mapM (scanSpecifier scanCount) (scans hdr) - modify $ \st -> st { seenBlobs = seenBlobs st + 1 } - tell [(params, raw_data) ] - where (selectionLow, selectionHigh) = spectralSelection hdr - approxHigh = fromIntegral $ successiveApproxHigh hdr - approxLow = fromIntegral $ successiveApproxLow hdr - - scanSpecifier scanCount scanSpec = do - let dcIndex = fromIntegral $ dcEntropyCodingTable scanSpec - acIndex = fromIntegral $ acEntropyCodingTable scanSpec - comp = fromIntegral (componentSelector scanSpec) - 1 - dcTree <- gets $ (V.! dcIndex) . dcDecoderTables - acTree <- gets $ (V.! acIndex) . acDecoderTables - isProgressiveImage <- gets isProgressive - maxiW <- gets maximumHorizontalResolution - maxiH <- gets maximumVerticalResolution - restart <- gets currentRestartInterv - frameInfo <- gets currentFrame - blobId <- gets seenBlobs - case frameInfo of - Nothing -> fail "Jpg decoding error - no previous frame" - Just v -> do - let compDesc = jpgComponents v !! comp - compCount = length $ jpgComponents v - xSampling = fromIntegral $ horizontalSamplingFactor compDesc - ySampling = fromIntegral $ verticalSamplingFactor compDesc - componentSubSampling = - (maxiW - xSampling + 1, maxiH - ySampling + 1) - (xCount, yCount) - | scanCount > 1 || isProgressiveImage = (xSampling, ySampling) - | otherwise = (1, 1) - - pure [ (JpgUnpackerParameter - { dcHuffmanTree = dcTree - , acHuffmanTree = acTree - , componentIndex = comp - , restartInterval = fromIntegral restart - , componentWidth = xSampling - , componentHeight = ySampling - , subSampling = componentSubSampling - , successiveApprox = (approxLow, approxHigh) - , readerIndex = blobId - , indiceVector = - if selectionLow == 0 then 0 else 1 - , coefficientRange = - ( fromIntegral selectionLow - , fromIntegral selectionHigh ) - , blockIndex = y * ySampling + x - , blockMcuX = x - , blockMcuY = y - }, unpackerDecision compCount componentSubSampling) - | y <- [0 .. yCount - 1] - , x <- [0 .. xCount - 1] ] - -jpgMachineStep (JpgScans kind hdr) = modify $ \s -> - s { currentFrame = Just hdr - , isProgressive = case kind of - JpgProgressiveDCTHuffman -> True - _ -> False - , maximumHorizontalResolution = - fromIntegral $ maximum horizontalResolutions - , maximumVerticalResolution = - fromIntegral $ maximum verticalResolutions - } - where components = jpgComponents hdr - horizontalResolutions = map horizontalSamplingFactor components - verticalResolutions = map verticalSamplingFactor components -jpgMachineStep (JpgIntervalRestart restart) = - modify $ \s -> s { currentRestartInterv = fromIntegral restart } -jpgMachineStep (JpgHuffmanTable tables) = mapM_ placeHuffmanTrees tables - where placeHuffmanTrees (spec, tree) = case huffmanTableClass spec of - DcComponent -> modify $ \s -> - let neu = dcDecoderTables s // [(idx, tree)] in - s { dcDecoderTables = neu `seq` neu } - where idx = fromIntegral $ huffmanTableDest spec - - AcComponent -> modify $ \s -> - s { acDecoderTables = acDecoderTables s // [(idx, tree)] } - where idx = fromIntegral $ huffmanTableDest spec - -jpgMachineStep (JpgQuantTable tables) = mapM_ placeQuantizationTables tables - where placeQuantizationTables table = do - let idx = fromIntegral $ quantDestination table - tableData = quantTable table - modify $ \s -> - s { quantizationMatrices = quantizationMatrices s // [(idx, tableData)] } - -unpackerDecision :: Int -> (Int, Int) -> Unpacker s -unpackerDecision 1 (1, 1) = unpack444Y -unpackerDecision _ (1, 1) = unpack444Ycbcr -unpackerDecision _ (2, 1) = unpack421Ycbcr -unpackerDecision compCount (xScalingFactor, yScalingFactor) = - unpackMacroBlock compCount xScalingFactor yScalingFactor - -decodeImage :: JpgFrameHeader - -> V.Vector (MacroBlock Int16) - -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] - -> MutableImage s PixelYCbCr8 -- ^ Result image to write into - -> ST s () -decodeImage frame quants lst outImage = do - let compCount = length $ jpgComponents frame - zigZagArray <- createEmptyMutableMacroBlock - dcArray <- M.replicate compCount 0 :: ST s (M.STVector s DcCoefficient) - resetCounter <- newSTRef restartIntervalValue - - forM_ lst $ \(params, str) -> do - let componentsInfo = V.fromList params - compReader = initBoolStateJpg . B.concat $ L.toChunks str - maxiW = maximum [fst $ subSampling c | (c,_) <- params] - maxiH = maximum [snd $ subSampling c | (c,_) <- params] - mcuBlockWidth = maxiW * dctBlockSize - mcuBlockHeight = maxiH * dctBlockSize - imageMcuWidth = (imgWidth + mcuBlockWidth - 1) `div` mcuBlockWidth - imageMcuHeight = (imgHeight + mcuBlockHeight - 1) `div` mcuBlockHeight - - execBoolReader compReader $ rasterMap imageMcuWidth imageMcuHeight $ \x y -> do - resetLeft <- lift $ readSTRef resetCounter - if resetLeft == 0 then do - lift $ M.set dcArray 0 - byteAlignJpg - _restartCode <- decodeRestartInterval - lift $ resetCounter `writeSTRef` (restartIntervalValue - 1) - else - lift $ resetCounter `writeSTRef` (resetLeft - 1) - - V.forM_ componentsInfo $ \(comp, unpack) -> do - let compIdx = componentIndex comp - dcTree = dcHuffmanTree comp - acTree = acHuffmanTree comp - qTable = quants V.! (min 1 compIdx) - xd = blockMcuX comp - yd = blockMcuY comp - (subX, subY) = subSampling comp - dc <- lift $ dcArray `M.unsafeRead` compIdx - (dcCoeff, block) <- - decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc - lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff - let verticalLimited = y == imageMcuHeight - 1 - if (x == imageMcuWidth - 1) || verticalLimited then - lift $ unpackMacroBlock imgComponentCount - subX subY compIdx - (x * maxiW + xd) (y * maxiH + yd) outImage block - else - lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block - - where imgComponentCount = length $ jpgComponents frame - - imgWidth = fromIntegral $ jpgWidth frame - imgHeight = fromIntegral $ jpgHeight frame - restartIntervalValue = case lst of - ((p,_):_,_): _ -> restartInterval p - _ -> -1 - -gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind -gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of - [JpgBaselineDCTHuffman] -> Just BaseLineDCT - [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT - _ -> Nothing - where isDctSpecifier JpgProgressiveDCTHuffman = True - isDctSpecifier JpgBaselineDCTHuffman = True - isDctSpecifier _ = False - -gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) -gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img] - --- | 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 'convertImage' from the 'ColorSpaceConvertible' --- typeclass. --- --- This function can output the following pixel types : --- --- * PixelY8 --- --- * PixelYCbCr8 --- -decodeJpeg :: B.ByteString -> Either String DynamicImage -decodeJpeg file = case runGetStrict get file of - Left err -> Left err - Right img -> case (compCount, imgKind) of - (_, Nothing) -> Left "Unknown Jpg kind" - (3, Just ProgressiveDCT) -> Right . ImageYCbCr8 $ decodeProgressive - (1, Just BaseLineDCT) -> Right . ImageY8 $ Image imgWidth imgHeight pixelData - (3, Just BaseLineDCT) -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData - _ -> Left "Wrong component count" - - where compCount = length $ jpgComponents scanInfo - (_,scanInfo) = gatherScanInfo img - - imgKind = gatherImageKind $ jpgFrame img - imgWidth = fromIntegral $ jpgWidth scanInfo - imgHeight = fromIntegral $ jpgHeight scanInfo - - imageSize = imgWidth * imgHeight * compCount - (st, wrotten) = execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - - decodeProgressive = runST $ - progressiveUnpack - (maximumHorizontalResolution st, maximumVerticalResolution st) - fHdr - (quantizationMatrices st) - wrotten >>= unsafeFreezeImage - - pixelData = runST $ do - resultImage <- M.new imageSize - let wrapped = MutableImage imgWidth imgHeight resultImage - decodeImage - fHdr - (quantizationMatrices st) - wrotten - wrapped - VS.unsafeFreeze resultImage - -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 * dctBlockSize) + 7 < w && (by * 8) + 7 < h = do - let baseReadIdx = (by * dctBlockSize * w) + bx * dctBlockSize - sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) val - | y <- [0 .. dctBlockSize - 1] - , let blockReadIdx = baseReadIdx + y * w - , x <- [0 .. dctBlockSize - 1] - , let val = fromIntegral $ src `VS.unsafeIndex` ((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 `VS.unsafeIndex` 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 * dctBlockSize * sampWidth - blockYBegin = by * dctBlockSize * sampHeight - - sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ] - return block - -serializeMacroBlock :: BoolWriteStateRef s - -> HuffmanWriterCode -> HuffmanWriterCode - -> MutableMacroBlock s Int32 - -> ST s () -serializeMacroBlock !st !dcCode !acCode !blk = - (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return () - where writeAcs acc@(_, 63) = - (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return () - writeAcs acc@(_, i ) = - (blk `M.unsafeRead` i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs - - encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount) - >> when (ssss /= 0) (encodeInt st ssss n) - where ssss = powerOf $ fromIntegral n - (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss - - encodeAc 0 0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount - where (bitCount, code) = acCode `V.unsafeIndex` 0 - - encodeAc zeroCount n | zeroCount >= 16 = - writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeAc (zeroCount - 16) n - where (bitCount, code) = acCode `V.unsafeIndex` 0xF0 - encodeAc zeroCount n = - writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n - where rrrr = zeroCount `unsafeShiftL` 4 - ssss = powerOf $ fromIntegral n - rrrrssss = rrrr .|. ssss - (bitCount, code) = acCode `V.unsafeIndex` 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 `M.unsafeRead` 0 - (blk `M.unsafeWrite` 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, HuffmanPackedTree) -prepareHuffmanTable classVal dest tableDef = - (JpgHuffmanTableSpec { huffmanTableClass = classVal - , huffmanTableDest = dest - , huffSizes = sizes - , huffCodes = V.fromListN 16 - [VU.fromListN (fromIntegral $ sizes ! i) lst - | (i, lst) <- zip [0..] tableDef ] - }, VS.singleton 0) - where sizes = VU.fromListN 16 $ 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 -> L.ByteString -encodeJpeg = encodeJpegAtQuality 50 - -defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)] -defaultHuffmanTables = - [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable - , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable - , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable - , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable - ] - --- | 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 - -> L.ByteString -- ^ Encoded JPEG -encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage - where finalImage = JpgImage [ JpgQuantTable quantTables - , JpgScans JpgBaselineDCTHuffman hdr - , JpgHuffmanTable defaultHuffmanTables - , JpgScanBlob scanHeader encodedImage - ] - - 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 $ do - let horizontalMetaBlockCount = - w `divUpward` (dctBlockSize * maxSampling) - verticalMetaBlockCount = - h `divUpward` (dctBlockSize * 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 - - dc_table <- M.replicate 3 0 - block <- createEmptyMutableMacroBlock - workData <- createEmptyMutableMacroBlock - zigzaged <- createEmptyMutableMacroBlock - writeState <- newWriteStateRef - - -- It's ugly, I know, be avoid allocation - let blockDecoder mx my = component $ zip [0..] componentDef - where component [] = return () - component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = - rasterMap sizeX sizeY decoder >> component comp_rest - where xSamplingFactor = maxSampling - sizeX + 1 - ySamplingFactor = maxSampling - sizeY + 1 - extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount - - decoder subX subY = do - let blockY = my * sizeY + subY - blockX = mx * sizeX + subX - prev_dc <- dc_table `M.unsafeRead` comp - (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= - encodeMacroBlock table workData zigzaged prev_dc) - (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff - serializeMacroBlock writeState dc ac neo_block - - rasterMap - horizontalMetaBlockCount verticalMetaBlockCount - blockDecoder - - finalizeBoolWriter writeState - diff --git a/Codec/Picture/Jpg/Common.hs b/Codec/Picture/Jpg/Common.hs deleted file mode 100644 --- a/Codec/Picture/Jpg/Common.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -module Codec.Picture.Jpg.Common - ( DctCoefficients - , JpgUnpackerParameter( .. ) - , decodeInt - , dcCoefficientDecode - , deQuantize - , decodeRrrrSsss - , zigZagReorderForward - , zigZagReorderForwardv - , zigZagReorder - , inverseDirectCosineTransform - , unpackInt - , unpackMacroBlock - , rasterMap - , decodeMacroBlock - , decodeRestartInterval - ) where - -import Control.Applicative( (<$>), pure ) -import Control.Monad( replicateM, when ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) -import Data.Int( Int16, Int32 ) -import Data.List( foldl' ) -import Data.Maybe( fromMaybe ) -import Data.Word( Word8 ) -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import Foreign.Storable ( Storable ) - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.FastIdct -import Codec.Picture.Jpg.DefaultTable - --- | Same as for DcCoefficient, to provide nicer type signatures -type DctCoefficients = DcCoefficient - -data JpgUnpackerParameter = JpgUnpackerParameter - { dcHuffmanTree :: !HuffmanPackedTree - , acHuffmanTree :: !HuffmanPackedTree - , componentIndex :: {-# UNPACK #-} !Int - , restartInterval :: {-# UNPACK #-} !Int - , componentWidth :: {-# UNPACK #-} !Int - , componentHeight :: {-# UNPACK #-} !Int - , subSampling :: !(Int, Int) - , coefficientRange :: !(Int, Int) - , successiveApprox :: !(Int, Int) - , readerIndex :: {-# UNPACK #-} !Int - , indiceVector :: {-# UNPACK #-} !Int - , blockIndex :: {-# UNPACK #-} !Int - , blockMcuX :: {-# UNPACK #-} !Int - , blockMcuY :: {-# UNPACK #-} !Int - } - deriving Show - -decodeRestartInterval :: BoolReader s Int32 -decodeRestartInterval = return (-1) {- do - bits <- replicateM 8 getNextBitJpg - if bits == replicate 8 True - then do - marker <- replicateM 8 getNextBitJpg - return $ packInt marker - else return (-1) - -} - -{-# INLINE decodeInt #-} -decodeInt :: Int -> BoolReader s Int32 -decodeInt ssss = do - signBit <- getNextBitJpg - let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) - leftBitCount = ssss - 1 - -- First following bits store the sign of the coefficient, and counted in - -- SSSS, so the bit count for the int, is ssss - 1 - if signBit - then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount - else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount - -decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) -decodeRrrrSsss tree = do - rrrrssss <- huffmanPackedDecode tree - let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF - ssss = rrrrssss .&. 0xF - pure (fromIntegral rrrr, fromIntegral ssss) - -dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient -dcCoefficientDecode dcTree = do - ssss <- huffmanPackedDecode dcTree - if ssss == 0 - then return 0 - else fromIntegral <$> decodeInt (fromIntegral ssss) - --- | Apply a quantization matrix to a macroblock -{-# INLINE deQuantize #-} -deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -deQuantize table block = update 0 - where update 64 = return block - update i = do - val <- block `M.unsafeRead` i - let finalValue = val * (table `VS.unsafeIndex` i) - (block `M.unsafeWrite` i) finalValue - update $ i + 1 - -inverseDirectCosineTransform :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -inverseDirectCosineTransform mBlock = - fastIdct mBlock >>= mutableLevelShift - -zigZagOrder :: MacroBlock Int -zigZagOrder = makeMacroBlock $ concat - [[ 0, 1, 5, 6,14,15,27,28] - ,[ 2, 4, 7,13,16,26,29,42] - ,[ 3, 8,12,17,25,30,41,43] - ,[ 9,11,18,24,31,40,44,53] - ,[10,19,23,32,39,45,52,54] - ,[20,22,33,38,46,51,55,60] - ,[21,34,37,47,50,56,59,61] - ,[35,36,48,49,57,58,62,63] - ] - -zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a -zigZagReorderForwardv vec = runST $ do - v <- M.new 64 - mv <- VS.thaw vec - zigZagReorderForward v mv >>= VS.freeze - -zigZagOrderForward :: MacroBlock Int -zigZagOrderForward = VS.generate 64 inv - where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder - -zigZagReorderForward :: (Storable a, Num a) - => MutableMacroBlock s a - -> MutableMacroBlock s a - -> ST s (MutableMacroBlock s a) -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int32 - -> ST s (MutableMacroBlock s Int32) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) #-} -{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 - -> MutableMacroBlock s Word8 - -> ST s (MutableMacroBlock s Word8) #-} -zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged - where ordering !table = reorder (0 :: Int) - where reorder !i | i >= 64 = return () - reorder i = do - let idx = table `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - reorder (i + 1) - -zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -zigZagReorder zigzaged block = do - let update i = do - let idx = zigZagOrder `VS.unsafeIndex` i - v <- block `M.unsafeRead` idx - (zigzaged `M.unsafeWrite` i) v - - reorder 63 = update 63 - reorder i = update i >> reorder (i + 1) - - reorder (0 :: Int) - return zigzaged - --- | Unpack an int of the given size encoded from MSB to LSB. -unpackInt :: Int -> BoolReader s Int32 -unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg - - -{-# INLINE rasterMap #-} -rasterMap :: (Monad m) - => Int -> Int -> (Int -> Int -> m ()) - -> m () -rasterMap width height f = liner 0 - where liner y | y >= height = return () - liner y = columner 0 - where columner x | x >= width = liner (y + 1) - columner x = f x y >> columner (x + 1) - -packInt :: [Bool] -> Int32 -packInt = foldl' bitStep 0 - where bitStep acc True = (acc `unsafeShiftL` 1) + 1 - bitStep acc False = acc `unsafeShiftL` 1 - -pixelClamp :: Int16 -> Word8 -pixelClamp n = fromIntegral . min 255 $ max 0 n - --- | Given a size coefficient (how much a pixel span horizontally --- and vertically), the position of the macroblock, return a list --- of indices and value to be stored in an array (like the final --- image) -unpackMacroBlock :: Int -- ^ Component count - -> Int -- ^ Width coefficient - -> Int -- ^ Height coefficient - -> Int -- ^ x - -> Int -- ^ y - -> Int -- ^ Component index - -> MutableImage s PixelYCbCr8 - -> MutableMacroBlock s Int16 - -> ST s () -unpackMacroBlock compCount wCoeff hCoeff compIdx x y - (MutableImage { mutableImageWidth = imgWidth, - mutableImageHeight = imgHeight, mutableImageData = img }) - block = rasterMap dctBlockSize dctBlockSize unpacker - where unpacker i j = do - let yBase = y * dctBlockSize + j * hCoeff - compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) - rasterMap wCoeff hCoeff $ \wDup hDup -> do - let xBase = x * dctBlockSize + i * wCoeff - xPos = xBase + wDup - yPos = yBase + hDup - - when (xPos < imgWidth && yPos < imgHeight) - (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx - (img `M.unsafeWrite` mutableIdx) compVal) - --- | This is one of the most important function of the decoding, --- it form the barebone decoding pipeline for macroblock. It's all --- there is to know for macro block transformation -decodeMacroBlock :: MacroBlock DctCoefficients - -> MutableMacroBlock s Int16 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -decodeMacroBlock quantizationTable zigZagBlock block = - deQuantize quantizationTable block >>= zigZagReorder zigZagBlock - >>= inverseDirectCosineTransform - diff --git a/Codec/Picture/Jpg/DefaultTable.hs b/Codec/Picture/Jpg/DefaultTable.hs deleted file mode 100644 --- a/Codec/Picture/Jpg/DefaultTable.hs +++ /dev/null @@ -1,294 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE FlexibleContexts #-} --- | Module used by the jpeg decoder internally, shouldn't be used --- in user code. -module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) - , HuffmanTree( .. ) - , HuffmanTable - , HuffmanPackedTree - , MacroBlock - , QuantificationTable - , HuffmanWriterCode - , scaleQuantisationMatrix - , makeMacroBlock - , makeInverseTable - , buildHuffmanTree - , packHuffmanTree - , huffmanPackedDecode - - , defaultChromaQuantizationTable - - , defaultLumaQuantizationTable - - , defaultAcChromaHuffmanTree - , defaultAcChromaHuffmanTable - - , defaultAcLumaHuffmanTree - , defaultAcLumaHuffmanTable - - , defaultDcChromaHuffmanTree - , defaultDcChromaHuffmanTable - - , defaultDcLumaHuffmanTree - , defaultDcLumaHuffmanTable - ) where - -import Data.Int( Int16 ) -import Foreign.Storable ( Storable ) -import Control.Monad.ST( runST ) -import qualified Data.Vector.Storable as SV -import qualified Data.Vector as V -import Data.Bits( unsafeShiftL, (.|.), (.&.) ) -import Data.Word( Word8, Word16 ) -import Data.List( foldl' ) -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - --- | Tree storing the code used for huffman encoding. -data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. - | Leaf Word8 -- ^ We should output the value - | Empty -- ^ no value present - deriving (Eq, Show) - -type HuffmanPackedTree = SV.Vector Word16 - -type HuffmanWriterCode = V.Vector (Word8, Word16) - -packHuffmanTree :: HuffmanTree -> HuffmanPackedTree -packHuffmanTree tree = runST $ do - table <- M.replicate 512 0x8000 - let aux (Empty) idx = return $ idx + 1 - aux (Leaf v) idx = do - (table `M.unsafeWrite` idx) $ (fromIntegral v .|. 0x4000) - return $ idx + 1 - - aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = - aux i1 idx >>= aux i2 - - aux (Branch i1@(Leaf _) i2) idx = do - _ <- aux i1 idx - ix2 <- aux i2 $ idx + 2 - (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2 - return ix2 - - aux (Branch i1 i2@(Leaf _)) idx = do - ix1 <- aux i1 (idx + 2) - _ <- aux i2 (idx + 1) - (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2 - return ix1 - - aux (Branch i1 i2) idx = do - ix1 <- aux i1 (idx + 2) - ix2 <- aux i2 ix1 - (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2) - (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1) - return ix2 - _ <- aux tree 0 - SV.unsafeFreeze table - -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 `unsafeShiftL` 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 = 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 = SV.fromListN 64 - --- | Enumeration used to search in the tables for different components. -data DctComponent = DcComponent | AcComponent - deriving (Eq, Show) - --- | Transform parsed coefficients from the jpeg header to a --- tree which can be used to decode data. -buildHuffmanTree :: [[Word8]] -> HuffmanTree -buildHuffmanTree table = foldl' insertHuffmanVal Empty - . concatMap (\(i, t) -> map (i + 1,) t) - $ zip ([0..] :: [Int]) table - where isTreeFullyDefined Empty = False - isTreeFullyDefined (Leaf _) = True - isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r - - insertHuffmanVal Empty (0, val) = Leaf val - insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty - insertHuffmanVal (Branch l r) (d, val) - | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) - | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r - insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" - -scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable -scaleQuantisationMatrix quality - | quality < 0 = scaleQuantisationMatrix 0 - -- shouldn't show much difference than with 1, - -- but hey, at least we're complete - | quality == 0 = SV.map (scale (10000 :: Int)) - | 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 - -huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8 -huffmanPackedDecode table = getNextBitJpg >>= aux 0 - where aux idx b - | (v .&. 0x8000) /= 0 = return 0 - | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF - | otherwise = getNextBitJpg >>= aux v - where tableIndex | b = idx + 1 - | otherwise = idx - v = table `SV.unsafeIndex` fromIntegral tableIndex - -defaultLumaQuantizationTable :: QuantificationTable -defaultLumaQuantizationTable = makeMacroBlock - [16, 11, 10, 16, 24, 40, 51, 61 - ,12, 12, 14, 19, 26, 58, 60, 55 - ,14, 13, 16, 24, 40, 57, 69, 56 - ,14, 17, 22, 29, 51, 87, 80, 62 - ,18, 22, 37, 56, 68, 109, 103, 77 - ,24, 35, 55, 64, 81, 104, 113, 92 - ,49, 64, 78, 87, 103, 121, 120, 101 - ,72, 92, 95, 98, 112, 100, 103, 99 - ] - -defaultChromaQuantizationTable :: QuantificationTable -defaultChromaQuantizationTable = makeMacroBlock - [17, 18, 24, 47, 99, 99, 99, 99 - ,18, 21, 26, 66, 99, 99, 99, 99 - ,24, 26, 56, 99, 99, 99, 99, 99 - ,47, 66, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ,99, 99, 99, 99, 99, 99, 99, 99 - ,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 :: HuffmanTable -defaultDcLumaHuffmanTable = - [ [] - , [0] - , [1, 2, 3, 4, 5] - , [6] - , [7] - , [8] - , [9] - , [10] - , [11] - , [] - , [] - , [] - , [] - , [] - , [] - , [] - ] - -defaultDcChromaHuffmanTree :: HuffmanTree -defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable - --- | From the Table K.4 of ITU-81 (p153) -defaultDcChromaHuffmanTable :: HuffmanTable -defaultDcChromaHuffmanTable = - [ [] - , [0, 1, 2] - , [3] - , [4] - , [5] - , [6] - , [7] - , [8] - , [9] - , [10] - , [11] - , [] - , [] - , [] - , [] - , [] - ] - -defaultAcLumaHuffmanTree :: HuffmanTree -defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable - --- | From the Table K.5 of ITU-81 (p154) -defaultAcLumaHuffmanTable :: HuffmanTable -defaultAcLumaHuffmanTable = - [ [] - , [0x01, 0x02] - , [0x03] - , [0x00, 0x04, 0x11] - , [0x05, 0x12, 0x21] - , [0x31, 0x41] - , [0x06, 0x13, 0x51, 0x61] - , [0x07, 0x22, 0x71] - , [0x14, 0x32, 0x81, 0x91, 0xA1] - , [0x08, 0x23, 0x42, 0xB1, 0xC1] - , [0x15, 0x52, 0xD1, 0xF0] - , [0x24, 0x33, 0x62, 0x72] - , [] - , [] - , [0x82] - , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 - ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 - ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 - ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A - ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 - ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 - ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA - ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 - ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] - ] - -type HuffmanTable = [[Word8]] - -defaultAcChromaHuffmanTree :: HuffmanTree -defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable - -defaultAcChromaHuffmanTable :: HuffmanTable -defaultAcChromaHuffmanTable = - [ [] - , [0x00, 0x01] - , [0x02] - , [0x03, 0x11] - , [0x04, 0x05, 0x21, 0x31] - , [0x06, 0x12, 0x41, 0x51] - , [0x07, 0x61, 0x71] - , [0x13, 0x22, 0x32, 0x81] - , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] - , [0x09, 0x23, 0x33, 0x52, 0xF0] - , [0x15, 0x62, 0x72, 0xD1] - , [0x0A, 0x16, 0x24, 0x34] - , [] - , [0xE1] - , [0x25, 0xF1] - , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 - , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 - , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 - , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 - , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 - , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 - , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 - , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 - , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 - , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 - , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA - , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA - ] - ] - diff --git a/Codec/Picture/Jpg/FastDct.hs b/Codec/Picture/Jpg/FastDct.hs deleted file mode 100644 --- a/Codec/Picture/Jpg/FastDct.hs +++ /dev/null @@ -1,203 +0,0 @@ -module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where - -import Control.Applicative( (<$>) ) -import Data.Int( Int16, Int32 ) -import Data.Bits( Bits, unsafeShiftR, unsafeShiftL ) -import Control.Monad.ST( ST ) - -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Jpg.Types -import Control.Monad( forM, forM_ ) - --- | 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 .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] (\(u,v) -> do - val <- at (u,v) - (workData `M.unsafeWrite` (v * dctBlockSize + 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..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do - sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + 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 _ i | i == dctBlockSize = return () - firstPass dataBlock i = do - let baseIdx = i * dctBlockSize - readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) - mult = (*) - writeAt idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) n - writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) - (n `unsafeShiftR` (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 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (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 `unsafeShiftL` (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 `M.unsafeRead` ((7 - i) + idx * dctBlockSize) - mult = (*) - writeAt idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) n - writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (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 `unsafeShiftL` (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) `unsafeShiftR` (pASS1_BITS + 3) - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (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 `unsafeShiftL` (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 deleted file mode 100644 --- a/Codec/Picture/Jpg/FastIdct.hs +++ /dev/null @@ -1,228 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} --- | Module providing a 'fast' implementation of IDCT --- --- inverse two dimensional DCT, Chen-Wang algorithm --- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) --- 32-bit integer arithmetic (8 bit coefficients) --- 11 mults, 29 adds per DCT --- sE, 18.8.91 --- --- coefficients extended to 12 bit for IEEE1180-1990 --- compliance sE, 2.1.94 --- --- this code assumes >> to be a two's-complement arithmetic --- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 -module Codec.Picture.Jpg.FastIdct( MutableMacroBlock - , fastIdct - , mutableLevelShift - , createEmptyMutableMacroBlock - ) where - -import qualified Data.Vector.Storable as V -import Control.Monad.ST( ST ) -import Data.Bits( unsafeShiftL, unsafeShiftR ) -import Data.Int( Int16 ) -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Jpg.Types - -iclip :: V.Vector Int16 -iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] - where val i | i < (-256) = -256 - | i > 255 = 255 - | otherwise = i - -data IDctStage = IDctStage { - x0 :: {-# UNPACK #-} !Int, - x1 :: {-# UNPACK #-} !Int, - x2 :: {-# UNPACK #-} !Int, - x3 :: {-# UNPACK #-} !Int, - x4 :: {-# UNPACK #-} !Int, - x5 :: {-# UNPACK #-} !Int, - x6 :: {-# UNPACK #-} !Int, - x7 :: {-# UNPACK #-} !Int, - x8 :: {-# UNPACK #-} !Int - } - -w1, w2, w3, w5, w6, w7 :: Int -w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) -w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) -w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) -w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) -w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) -w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) - --- row (horizontal) IDCT --- --- 7 pi 1 --- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) --- l=0 8 2 --- --- where: c[0] = 128 --- c[1..7] = 128*sqrt(2) -idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () -idctRow blk idx = do - xx0 <- blk `M.unsafeRead` (0 + idx) - xx1 <- blk `M.unsafeRead` (4 + idx) - xx2 <- blk `M.unsafeRead` (6 + idx) - xx3 <- blk `M.unsafeRead` (2 + idx) - xx4 <- blk `M.unsafeRead` (1 + idx) - xx5 <- blk `M.unsafeRead` (7 + idx) - xx6 <- blk `M.unsafeRead` (5 + idx) - xx7 <- blk `M.unsafeRead` (3 + idx) - let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128 - , x1 = fromIntegral xx1 `unsafeShiftL` 11 - , x2 = fromIntegral xx2 - , x3 = fromIntegral xx3 - , x4 = fromIntegral xx4 - , x5 = fromIntegral xx5 - , x6 = fromIntegral xx6 - , x7 = fromIntegral xx7 - , x8 = 0 - } - - firstStage c = c { x4 = x8' + (w1 - w7) * x4 c - , x5 = x8' - (w1 + w7) * x5 c - , x6 = x8'' - (w3 - w5) * x6 c - , x7 = x8'' - (w3 + w5) * x7 c - , x8 = x8'' - } - where x8' = w7 * (x4 c + x5 c) - x8'' = w3 * (x6 c + x7 c) - - secondStage c = c { x0 = x0 c - x1 c - , x8 = x0 c + x1 c - , x1 = x1'' - , x2 = x1' - (w2 + w6) * x2 c - , x3 = x1' + (w2 - w6) * x3 c - , x4 = x4 c - x6 c - , x6 = x5 c + x7 c - , x5 = x5 c - x7 c - } - where x1' = w6 * (x3 c + x2 c) - x1'' = x4 c + x6 c - - thirdStage c = c { x7 = x8 c + x3 c - , x8 = x8 c - x3 c - , x3 = x0 c + x2 c - , x0 = x0 c - x2 c - , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 - , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 - } - scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8 - , x1 = (x3 c + x2 c) `unsafeShiftR` 8 - , x2 = (x0 c + x4 c) `unsafeShiftR` 8 - , x3 = (x8 c + x6 c) `unsafeShiftR` 8 - , x4 = (x8 c - x6 c) `unsafeShiftR` 8 - , x5 = (x0 c - x4 c) `unsafeShiftR` 8 - , x6 = (x3 c - x2 c) `unsafeShiftR` 8 - , x7 = (x7 c - x1 c) `unsafeShiftR` 8 - } - transformed = scaled . thirdStage . secondStage $ firstStage initialState - - (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed - (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed - (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed - (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed - (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed - (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed - (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed - (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed - --- column (vertical) IDCT --- --- 7 pi 1 --- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) --- l=0 8 2 --- --- where: c[0] = 1/1024 --- c[1..7] = (1/1024)*sqrt(2) --- -idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () -idctCol blk idx = do - xx0 <- blk `M.unsafeRead` ( 0 + idx) - xx1 <- blk `M.unsafeRead` (8 * 4 + idx) - xx2 <- blk `M.unsafeRead` (8 * 6 + idx) - xx3 <- blk `M.unsafeRead` (8 * 2 + idx) - xx4 <- blk `M.unsafeRead` (8 + idx) - xx5 <- blk `M.unsafeRead` (8 * 7 + idx) - xx6 <- blk `M.unsafeRead` (8 * 5 + idx) - xx7 <- blk `M.unsafeRead` (8 * 3 + idx) - let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192 - , x1 = fromIntegral xx1 `unsafeShiftL` 8 - , x2 = fromIntegral xx2 - , x3 = fromIntegral xx3 - , x4 = fromIntegral xx4 - , x5 = fromIntegral xx5 - , x6 = fromIntegral xx6 - , x7 = fromIntegral xx7 - , x8 = 0 - } - firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) `unsafeShiftR` 3 - , x5 = (x8' - (w1 + w7) * x5 c) `unsafeShiftR` 3 - , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3 - , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3 - , x8 = x8'' - } - where x8' = w7 * (x4 c + x5 c) + 4 - x8'' = w3 * (x6 c + x7 c) + 4 - - secondStage c = c { x8 = x0 c + x1 c - , x0 = x0 c - x1 c - , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3 - , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3 - , x4 = x4 c - x6 c - , x1 = x1'' - , x6 = x5 c + x7 c - , x5 = x5 c - x7 c - } - where x1' = w6 * (x3 c + x2 c) + 4 - x1'' = x4 c + x6 c - - thirdStage c = c { x7 = x8 c + x3 c - , x8 = x8 c - x3 c - , x3 = x0 c + x2 c - , x0 = x0 c - x2 c - , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 - , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 - } - - clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512) - else iclip `V.unsafeIndex` 0 - - | otherwise = iclip `V.unsafeIndex` 1023 - - f = thirdStage . secondStage $ firstStage initialState - (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8 )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14 - (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14 - - -{-# INLINE fastIdct #-} --- | Algorithm to call to perform an IDCT, return the same --- block that the one given as input. -fastIdct :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -fastIdct block = rows 0 - where rows 8 = cols 0 - rows i = idctRow block (8 * i) >> rows (i + 1) - - cols 8 = return block - cols i = idctCol block i >> cols (i + 1) - -{-# INLINE mutableLevelShift #-} --- | Perform a Jpeg level shift in a mutable fashion. -mutableLevelShift :: MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int16) -mutableLevelShift block = update 0 - where update 64 = return block - update idx = do - val <- block `M.unsafeRead` idx - (block `M.unsafeWrite` idx) $ val + 128 - update $ idx + 1 - diff --git a/Codec/Picture/Jpg/Progressive.hs b/Codec/Picture/Jpg/Progressive.hs deleted file mode 100644 --- a/Codec/Picture/Jpg/Progressive.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -module Codec.Picture.Jpg.Progressive - ( JpgUnpackerParameter( .. ) - , progressiveUnpack - ) where - -import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( when, forM_ ) -import Control.Monad.ST( ST ) -import Control.Monad.Trans( lift ) -import Data.Bits( (.&.), (.|.), unsafeShiftL ) -import Data.Int( Int16, Int32 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import Data.Vector( (!) ) -import qualified Data.Vector.Mutable as M -import qualified Data.Vector.Storable.Mutable as MS - -import Codec.Picture.Types -import Codec.Picture.BitWriter -import Codec.Picture.Jpg.Common -import Codec.Picture.Jpg.Types -import Codec.Picture.Jpg.DefaultTable - -mcuIndexer :: JpgComponent -> DctComponent -> Int -> VS.Vector Int -mcuIndexer param kind mcuWidth = VS.fromListN (mcuWidth * th) indexes - where compW = fromIntegral $ horizontalSamplingFactor param - compH = fromIntegral $ verticalSamplingFactor param - th = compW * compH - - index AcComponent mcu y x = mcu * th + x + y * compW - index DcComponent mcu y x = (mcu + y * mcuWidth) * compW + x - indexes = - index kind <$> [0 .. mcuWidth - 1] <*> [0 .. compH - 1] <*> [0 .. compW - 1] - -createMcuLineIndices :: JpgComponent -> Int -> V.Vector (VS.Vector Int) -createMcuLineIndices comp mcuWidth = - V.fromList [ mcuIndexer comp part mcuWidth | part <- [DcComponent, AcComponent] ] - -decodeFirstDC :: JpgUnpackerParameter - -> MS.STVector s Int16 - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun - where unpack = do - (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params - previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params - let neoDcCoefficient = previousDc + dcDeltaCoefficient - approxLow = fst $ successiveApprox params - scaledDc = neoDcCoefficient `unsafeShiftL` approxLow - lift $ (block `MS.unsafeWrite` 0) scaledDc - lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient - -decodeRefineDc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineDc params _ block eobrun = unpack >> pure eobrun - where approxLow = fst $ successiveApprox params - plusOne = 1 `unsafeShiftL` approxLow - unpack = do - bit <- getNextBitJpg - when bit . lift $ do - v <- block `MS.unsafeRead` 0 - (block `MS.unsafeWrite` 0) $ v .|. plusOne - -decodeFirstAc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 -decodeFirstAc params _ block _ = unpack startIndex - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - unpack n | n > maxIndex = pure 0 - unpack n = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> unpack $ n + 16 - ( 0, 0) -> return 0 - ( r, 0) -> eobrun <$> unpackInt r - where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits - ( r, s) -> do - let n' = n + r - val <- (`unsafeShiftL` low) <$> decodeInt s - lift . (block `MS.unsafeWrite` n') $ fromIntegral val - unpack $ n' + 1 - -decodeRefineAc :: JpgUnpackerParameter - -> a - -> MutableMacroBlock s Int16 - -> Int32 - -> BoolReader s Int32 -decodeRefineAc params _ block eobrun - | eobrun == 0 = unpack startIndex - | otherwise = performEobRun startIndex >> return (eobrun - 1) - where (startIndex, maxIndex) = coefficientRange params - (low, _) = successiveApprox params - plusOne = 1 `unsafeShiftL` low - minusOne = (-1) `unsafeShiftL` low - - getBitVal = do - v <- getNextBitJpg - pure $ if v then plusOne else minusOne - - {-performEobRun :: Int -> BoolReader s ()-} - performEobRun idx | idx > maxIndex = pure () - performEobRun idx = do - coeff <- lift $ block `MS.unsafeRead` idx - when (coeff /= 0) $ do - bit <- getNextBitJpg - case (bit, (coeff .&. plusOne) == 0) of - (False, _) -> performEobRun $ idx + 1 - (True, False) -> performEobRun $ idx + 1 - (True, True) -> do - let newVal | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) newVal - performEobRun $ idx + 1 - - unpack idx | idx > maxIndex = pure 0 - unpack idx = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> error "Dunno" - ( r, 0) -> do - lowBits <- unpackInt r - let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 - performEobRun idx - pure newEobRun - - ( r, _) -> do - idx' <- updateCoeffs r idx - val <- getBitVal - when (idx <= maxIndex) $ - (lift $ (block `MS.unsafeWrite` idx') val) - unpack $ idx' + 1 - - updateCoeffs r idx - | r < 0 = pure idx - | idx > maxIndex = pure idx - updateCoeffs r idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if coeff /= 0 then do - bit <- getNextBitJpg - when (bit && coeff .&. plusOne == 0) $ - if coeff >= 0 then - lift . (block `MS.unsafeWrite` idx) $ coeff + plusOne - else - lift . (block `MS.unsafeWrite` idx) $ coeff + minusOne - updateCoeffs r $ idx + 1 - else - updateCoeffs (r - 1) $ idx + 1 - -type Unpacker s = - JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 - -> BoolReader s Int32 - - -prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) - , M.STVector s BoolState) -prepareUnpacker lst = do - let boolStates = V.fromList $ map snd infos - vec <- V.unsafeThaw boolStates - return (V.fromList $ map fst infos, vec) - where infos = map prepare lst - prepare ([], _) = error "progressiveUnpack, no component" - prepare (whole@((param, _) : _) , byteString) = - (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) - where unpacker = selection (successiveApprox param) (coefficientRange param) - boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString - - selection (_, 0) (0, _) = decodeFirstDC - selection (_, 0) _ = decodeFirstAc - selection _ (0, _) = decodeRefineDc - selection _ _ = decodeRefineAc - -data ComponentData s = ComponentData - { componentIndices :: V.Vector (VS.Vector Int) - , componentBlocks :: V.Vector (MutableMacroBlock s Int16) - , componentId :: !Int - , componentBlockCount :: !Int - } - --- | Iteration from to n in monadic context, without data --- keeping. -lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () -{-# INLINE lineMap #-} -lineMap count f = go 0 - where go n | n >= count = return () - go n = f n >> go (n + 1) - -progressiveUnpack :: (Int, Int) - -> JpgFrameHeader - -> V.Vector (MacroBlock Int16) - -> [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s (MutableImage s PixelYCbCr8) -progressiveUnpack (maxiW, maxiH) frame quants lst = do - (unpackers, readers) <- prepareUnpacker lst - allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame - :: ST s [ComponentData s] - let scanCount = length lst - restartIntervalValue = case lst of - ((p,_):_,_): _ -> restartInterval p - _ -> -1 - dcCoeffs <- MS.replicate imgComponentCount 0 - eobRuns <- MS.replicate (length lst) 0 - workBlock <- createEmptyMutableMacroBlock - writeIndices <- MS.replicate imgComponentCount (0 :: Int) - restartIntervals <- MS.replicate scanCount restartIntervalValue - let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount - img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 - - let processRestartInterval = - forM_ [0 .. scanCount - 1] $ \ix -> do - v <- restartIntervals `MS.read` ix - if v == 0 then do - -- reset DC prediction - when (ix == 0) (MS.set dcCoeffs 0) - reader <- readers `M.read` ix - (_, updated) <- runBoolReaderWith reader $ - byteAlignJpg >> decodeRestartInterval - (readers `M.write` ix) updated - (eobRuns `MS.unsafeWrite` ix) 0 - (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 - else - (restartIntervals `MS.unsafeWrite` ix) $ v - 1 - - - lineMap imageMcuHeight $ \mmY -> do - -- Reset all blocks to 0 - forM_ allBlocks $ V.mapM_ (flip MS.set 0) . componentBlocks - MS.set writeIndices 0 - - lineMap imageMcuWidth $ \_mmx -> do - processRestartInterval - V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do - boolState <- readers `M.read` readerIndex unpackParam - eobrun <- eobRuns `MS.read` readerIndex unpackParam - let componentNumber = componentIndex unpackParam - writeIndex <- writeIndices `MS.read` componentNumber - let componentData = allBlocks !! componentNumber - indexVector = - componentIndices componentData ! indiceVector unpackParam - realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) - writeBlock = - componentBlocks componentData ! realIndex - (eobrun', state) <- - runBoolReaderWith boolState $ - unpacker unpackParam dcCoeffs writeBlock eobrun - - (readers `M.write` readerIndex unpackParam) state - (eobRuns `MS.write` readerIndex unpackParam) eobrun' - - -- Update the write indices - forM_ allBlocks $ \comp -> do - writeIndex <- writeIndices `MS.read` componentId comp - let newIndex = writeIndex + componentBlockCount comp - (writeIndices `MS.write` componentId comp) $ newIndex - - forM_ allBlocks $ \compData -> do - let compBlocks = componentBlocks compData - cId = componentId compData - table = quants ! min 1 cId - comp = jpgComponents frame !! cId - compW = fromIntegral $ horizontalSamplingFactor comp - compH = fromIntegral $ verticalSamplingFactor comp - cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 - ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 - - rasterMap (imageMcuWidth * compW) compH $ \rx y -> do - let ry = mmY * maxiH + y - block = compBlocks ! (y * imageMcuWidth * compW + rx) - transformed <- decodeMacroBlock table workBlock block - unpackMacroBlock imgComponentCount - cw8 ch8 cId (rx * cw8) ry - img transformed - - return img - - where imgComponentCount = length $ jpgComponents frame - mcuBlockWidth = maxiW * dctBlockSize - mcuBlockHeight = maxiH * dctBlockSize - - imgWidth = fromIntegral $ jpgWidth frame - imgHeight = fromIntegral $ jpgHeight frame - imageMcuWidth = (imgWidth + mcuBlockWidth - 1) `div` mcuBlockWidth - imageMcuHeight = (imgHeight + mcuBlockHeight - 1) `div` mcuBlockHeight - - allocateWorkingBlocks (ix, comp) = do - let blockCount = hSample * vSample * imageMcuWidth - blocks <- V.replicateM blockCount createEmptyMutableMacroBlock - return $ ComponentData - { componentBlocks = blocks - , componentIndices = createMcuLineIndices comp imageMcuWidth - , componentBlockCount = hSample * vSample - , componentId = ix - } - where hSample = fromIntegral $ horizontalSamplingFactor comp - vSample = fromIntegral $ verticalSamplingFactor comp - diff --git a/Codec/Picture/Jpg/Types.hs b/Codec/Picture/Jpg/Types.hs deleted file mode 100644 --- a/Codec/Picture/Jpg/Types.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Codec.Picture.Jpg.Types( MutableMacroBlock - , createEmptyMutableMacroBlock - , printMacroBlock - , printPureMacroBlock - , DcCoefficient - , JpgImage( .. ) - , JpgComponent( .. ) - , JpgFrameHeader( .. ) - , JpgFrame( .. ) - , JpgFrameKind( .. ) - , JpgScanHeader( .. ) - , JpgQuantTableSpec( .. ) - , JpgHuffmanTableSpec( .. ) - , JpgImageKind( .. ) - , JpgScanSpecification( .. ) - , calculateSize - , dctBlockSize - ) where - -import Control.Applicative( (<$>), (<*>)) -import Control.Monad( when, replicateM, forM, forM_, unless ) -import Control.Monad.ST( ST ) -import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) -import Foreign.Storable ( Storable ) -import Data.Vector.Unboxed( (!) ) -import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as VU -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Data.Int( Int16 ) -import Data.Word(Word8, Word16 ) -import Data.Binary( Binary(..) ) - -import Data.Binary.Get( Get - , getWord8 - , getWord16be - , getByteString - , skip - , bytesRead - ) - -import Data.Binary.Put( Put - , putWord8 - , putWord16be - , putLazyByteString - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Jpg.DefaultTable - -{-import Debug.Trace-} -import Text.Printf - --- | Type only used to make clear what kind of integer we are carrying --- Might be transformed into newtype in the future -type DcCoefficient = Int16 - --- | Macroblock that can be transformed. -type MutableMacroBlock s a = M.STVector s a - -data JpgFrameKind = - JpgBaselineDCTHuffman - | JpgExtendedSequentialDCTHuffman - | JpgProgressiveDCTHuffman - | JpgLosslessHuffman - | JpgDifferentialSequentialDCTHuffman - | JpgDifferentialProgressiveDCTHuffman - | JpgDifferentialLosslessHuffman - | JpgExtendedSequentialArithmetic - | JpgProgressiveDCTArithmetic - | JpgLosslessArithmetic - | JpgDifferentialSequentialDCTArithmetic - | JpgDifferentialProgressiveDCTArithmetic - | JpgDifferentialLosslessArithmetic - | JpgQuantizationTable - | JpgHuffmanTableMarker - | JpgStartOfScan - | JpgEndOfImage - | JpgAppSegment Word8 - | JpgExtensionSegment Word8 - - | JpgRestartInterval - | JpgRestartIntervalEnd Word8 - deriving (Eq, Show) - -data JpgFrame = - JpgAppFrame !Word8 B.ByteString - | JpgExtension !Word8 B.ByteString - | JpgQuantTable ![JpgQuantTableSpec] - | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] - | JpgScanBlob !JpgScanHeader !L.ByteString - | JpgScans !JpgFrameKind !JpgFrameHeader - | JpgIntervalRestart !Word16 - deriving Show - -data JpgFrameHeader = JpgFrameHeader - { jpgFrameHeaderLength :: !Word16 - , jpgSamplePrecision :: !Word8 - , jpgHeight :: !Word16 - , jpgWidth :: !Word16 - , jpgImageComponentCount :: !Word8 - , 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 - , horizontalSamplingFactor :: !Word8 - -- | Stored with 4 bits - , verticalSamplingFactor :: !Word8 - , quantizationTableDest :: !Word8 - } - deriving Show - -instance SizeCalculable JpgComponent where - calculateSize _ = 3 - -data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } - deriving Show - -data JpgScanSpecification = JpgScanSpecification - { componentSelector :: !Word8 - -- | Encoded as 4 bits - , dcEntropyCodingTable :: !Word8 - -- | Encoded as 4 bits - , acEntropyCodingTable :: !Word8 - - } - deriving Show - -instance SizeCalculable JpgScanSpecification where - calculateSize _ = 2 - -data JpgScanHeader = JpgScanHeader - { scanLength :: !Word16 - , scanComponentCount :: !Word8 - , scans :: [JpgScanSpecification] - - -- | (begin, end) - , spectralSelection :: (Word8, Word8) - - -- | Encoded as 4 bits - , successiveApproxHigh :: !Word8 - - -- | Encoded as 4 bits - , successiveApproxLow :: !Word8 - } - 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 - - -- | Stored on 4 bits - , quantDestination :: !Word8 - - , quantTable :: MacroBlock Int16 - } - deriving Show - -class SizeCalculable a where - calculateSize :: a -> Int - --- | Type introduced only to avoid some typeclass overlapping --- problem -newtype TableList a = TableList [a] - -instance (SizeCalculable a, Binary a) => Binary (TableList a) where - put (TableList lst) = do - putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 - mapM_ put lst - - get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) - where innerParse :: Int -> Get [a] - innerParse 0 = return [] - innerParse size = do - onStart <- fromIntegral <$> bytesRead - table <- get - onEnd <- fromIntegral <$> bytesRead - (table :) <$> innerParse (size - (onEnd - onStart)) - -instance SizeCalculable JpgQuantTableSpec where - calculateSize table = - 1 + (fromIntegral (quantPrecision table) + 1) * 64 - -instance Binary JpgQuantTableSpec where - put table = do - let precision = quantPrecision table - put4BitsOfEach precision (quantDestination table) - forM_ (VS.toList $ quantTable table) $ \coeff -> - if precision == 0 then putWord8 $ fromIntegral coeff - else putWord16be $ fromIntegral coeff - - get = do - (precision, dest) <- get4BitOfEach - coeffs <- replicateM 64 $ if precision == 0 - then fromIntegral <$> getWord8 - else fromIntegral <$> getWord16be - return JpgQuantTableSpec - { quantPrecision = precision - , quantDestination = dest - , quantTable = VS.fromListN 64 coeffs - } - -data JpgHuffmanTableSpec = JpgHuffmanTableSpec - { -- | 0 : DC, 1 : AC, stored on 4 bits - huffmanTableClass :: !DctComponent - -- | Stored on 4 bits - , huffmanTableDest :: !Word8 - - , huffSizes :: !(VU.Vector Word8) - , huffCodes :: !(V.Vector (VU.Vector Word8)) - } - deriving Show - -instance SizeCalculable JpgHuffmanTableSpec where - calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] - -instance Binary JpgHuffmanTableSpec where - put table = do - let classVal = if huffmanTableClass table == DcComponent - then 0 else 1 - put4BitsOfEach classVal $ huffmanTableDest table - mapM_ put . VU.toList $ huffSizes table - forM_ [0 .. 15] $ \i -> - when (huffSizes table ! i /= 0) - (let elements = VU.toList $ huffCodes table V.! i - in mapM_ put elements) - - get = do - (huffClass, huffDest) <- get4BitOfEach - sizes <- replicateM 16 getWord8 - codes <- forM sizes $ \s -> - VU.replicateM (fromIntegral s) getWord8 - return JpgHuffmanTableSpec - { huffmanTableClass = - if huffClass == 0 then DcComponent else AcComponent - , huffmanTableDest = huffDest - , huffSizes = VU.fromListN 16 sizes - , huffCodes = V.fromListN 16 codes - } - -instance Binary JpgImage where - put (JpgImage { jpgFrame = frames }) = - putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames - >> putWord8 0xFF >> putWord8 0xD9 - - get = do - let startOfImageMarker = 0xD8 - -- endOfImageMarker = 0xD9 - checkMarker commonMarkerFirstByte startOfImageMarker - eatUntilCode - frames <- parseFrames - {-checkMarker commonMarkerFirstByte endOfImageMarker-} - return JpgImage { jpgFrame = frames } - -eatUntilCode :: Get () -eatUntilCode = do - code <- getWord8 - unless (code == 0xFF) eatUntilCode - -takeCurrentFrame :: Get B.ByteString -takeCurrentFrame = do - size <- getWord16be - getByteString (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 >> putLazyByteString blob -putFrame (JpgScans kind hdr) = - put kind >> put hdr - --------------------------------------------------- ----- Serialization instances --------------------------------------------------- -commonMarkerFirstByte :: Word8 -commonMarkerFirstByte = 0xFF - -checkMarker :: Word8 -> Word8 -> Get () -checkMarker b1 b2 = do - rb1 <- getWord8 - rb2 <- getWord8 - when (rb1 /= b1 || rb2 /= b2) - (fail "Invalid marker used") - -extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) -extractScanContent str = aux 0 - where maxi = fromIntegral $ L.length str - 1 - - aux n | n >= maxi = (str, L.empty) - | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str - | otherwise = aux (n + 1) - where v = str `L.index` n - vNext = str `L.index` (n + 1) - isReset = 0xD0 <= vNext && vNext <= 0xD7 - -parseFrames :: Get [JpgFrame] -parseFrames = do - kind <- get - let parseNextFrame = do - word <- getWord8 - when (word /= 0xFF) $ do - readedData <- bytesRead - fail $ "Invalid Frame marker (" ++ show word - ++ ", bytes read : " ++ show readedData ++ ")" - parseFrames - - case kind of - JpgEndOfImage -> return [] - JpgAppSegment c -> - (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgExtensionSegment c -> - (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame - JpgQuantizationTable -> - (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame - JpgRestartInterval -> - (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame - JpgHuffmanTableMarker -> - (\(TableList huffTables) lst -> - JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) - <$> get <*> parseNextFrame - JpgStartOfScan -> - (\frm imgData -> - let (d, other) = extractScanContent imgData - in - case runGet parseFrames (L.drop 1 other) of - Left _ -> [JpgScanBlob frm d] - Right lst -> JpgScanBlob frm d : lst - ) <$> get <*> getRemainingLazyBytes - - _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame - -buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree -buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList - -secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 -secondStartOfFrameByteOfKind = aux - where - aux JpgBaselineDCTHuffman = 0xC0 - aux JpgExtendedSequentialDCTHuffman = 0xC1 - aux JpgProgressiveDCTHuffman = 0xC2 - aux JpgLosslessHuffman = 0xC3 - aux JpgDifferentialSequentialDCTHuffman = 0xC5 - aux JpgDifferentialProgressiveDCTHuffman = 0xC6 - aux JpgDifferentialLosslessHuffman = 0xC7 - aux JpgExtendedSequentialArithmetic = 0xC9 - aux JpgProgressiveDCTArithmetic = 0xCA - aux JpgLosslessArithmetic = 0xCB - aux JpgHuffmanTableMarker = 0xC4 - aux JpgDifferentialSequentialDCTArithmetic = 0xCD - aux JpgDifferentialProgressiveDCTArithmetic = 0xCE - aux JpgDifferentialLosslessArithmetic = 0xCF - aux JpgEndOfImage = 0xD9 - aux JpgQuantizationTable = 0xDB - aux JpgStartOfScan = 0xDA - aux JpgRestartInterval = 0xDD - aux (JpgRestartIntervalEnd v) = v - aux (JpgAppSegment a) = a - aux (JpgExtensionSegment a) = a - -data JpgImageKind = BaseLineDCT | ProgressiveDCT - -instance Binary JpgFrameKind where - put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) - get = do - -- no lookahead :( - {-word <- getWord8-} - word2 <- getWord8 - return $ case word2 of - 0xC0 -> JpgBaselineDCTHuffman - 0xC1 -> JpgExtendedSequentialDCTHuffman - 0xC2 -> JpgProgressiveDCTHuffman - 0xC3 -> JpgLosslessHuffman - 0xC4 -> JpgHuffmanTableMarker - 0xC5 -> JpgDifferentialSequentialDCTHuffman - 0xC6 -> JpgDifferentialProgressiveDCTHuffman - 0xC7 -> JpgDifferentialLosslessHuffman - 0xC9 -> JpgExtendedSequentialArithmetic - 0xCA -> JpgProgressiveDCTArithmetic - 0xCB -> JpgLosslessArithmetic - 0xCD -> JpgDifferentialSequentialDCTArithmetic - 0xCE -> JpgDifferentialProgressiveDCTArithmetic - 0xCF -> JpgDifferentialLosslessArithmetic - 0xD9 -> JpgEndOfImage - 0xDA -> JpgStartOfScan - 0xDB -> JpgQuantizationTable - 0xDD -> JpgRestartInterval - a | a >= 0xF0 -> JpgExtensionSegment a - | a >= 0xE0 -> JpgAppSegment a - | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a - | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") - -put4BitsOfEach :: Word8 -> Word8 -> Put -put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b - -get4BitOfEach :: Get (Word8, Word8) -get4BitOfEach = do - val <- get - return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) - -newtype RestartInterval = RestartInterval Word16 - -instance Binary RestartInterval where - put (RestartInterval i) = putWord16be 4 >> putWord16be i - get = do - size <- getWord16be - when (size /= 4) (fail "Invalid jpeg restart interval size") - RestartInterval <$> getWord16be - -instance Binary JpgComponent where - get = do - ident <- getWord8 - (horiz, vert) <- get4BitOfEach - quantTableIndex <- getWord8 - return JpgComponent - { componentIdentifier = ident - , horizontalSamplingFactor = horiz - , verticalSamplingFactor = vert - , quantizationTableDest = quantTableIndex - } - put v = do - put $ componentIdentifier v - put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v - put $ quantizationTableDest v - -instance Binary JpgFrameHeader where - get = do - beginOffset <- fromIntegral <$> bytesRead - frmHLength <- getWord16be - samplePrec <- getWord8 - h <- getWord16be - w <- getWord16be - compCount <- getWord8 - components <- replicateM (fromIntegral compCount) get - endOffset <- fromIntegral <$> bytesRead - when (beginOffset - endOffset < fromIntegral frmHLength) - (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) - return JpgFrameHeader - { jpgFrameHeaderLength = frmHLength - , jpgSamplePrecision = samplePrec - , jpgHeight = h - , jpgWidth = w - , jpgImageComponentCount = compCount - , jpgComponents = components - } - - put v = do - putWord16be $ jpgFrameHeaderLength v - putWord8 $ jpgSamplePrecision v - putWord16be $ jpgHeight v - putWord16be $ jpgWidth v - putWord8 $ jpgImageComponentCount v - mapM_ put $ jpgComponents v - -instance Binary JpgScanSpecification where - put v = do - put $ componentSelector v - put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v - - get = do - compSel <- get - (dc, ac) <- get4BitOfEach - return JpgScanSpecification { - componentSelector = compSel - , dcEntropyCodingTable = dc - , acEntropyCodingTable = ac - } - -instance Binary JpgScanHeader where - get = do - thisScanLength <- getWord16be - compCount <- getWord8 - comp <- replicateM (fromIntegral compCount) get - specBeg <- get - specEnd <- get - (approxHigh, approxLow) <- get4BitOfEach - - return JpgScanHeader { - scanLength = thisScanLength, - scanComponentCount = compCount, - scans = comp, - spectralSelection = (specBeg, specEnd), - successiveApproxHigh = approxHigh, - successiveApproxLow = approxLow - } - - put v = do - putWord16be $ scanLength v - putWord8 $ scanComponentCount v - mapM_ put $ scans v - putWord8 . fst $ spectralSelection v - putWord8 . snd $ spectralSelection v - put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v - -{-# 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 - -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 `M.unsafeRead` i - vn <- pLn (i+1) - return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn - -printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String -printPureMacroBlock block = pLn 0 - where pLn 64 = "===============================\n" - pLn i = str ++ pLn (i + 1) - where str | i `mod` 8 == 0 = printf "\n%5d " v - | otherwise = printf "%5d" v - v = block VS.! i - - -{-# INLINE dctBlockSize #-} -dctBlockSize :: Num a => a -dctBlockSize = 8 diff --git a/Codec/Picture/Png.hs b/Codec/Picture/Png.hs deleted file mode 100644 --- a/Codec/Picture/Png.hs +++ /dev/null @@ -1,500 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} --- | Module used for loading & writing \'Portable Network Graphics\' (PNG) --- files. The API has two layers, the high level, which load the image without --- looking deeply about it and the low level, allowing access to data chunks contained --- in the PNG image. --- --- For general use, please use 'decodePng' function. --- --- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) -module Codec.Picture.Png( -- * High level functions - PngSavable( .. ) - - , decodePng - , writePng - , encodeDynamicPng - , writeDynamicPng - - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( forM_, foldM_, when ) -import Control.Monad.ST( ST, runST ) -import Data.Binary( Binary( get) ) - -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M -import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) -import Data.List( find, zip4 ) -import Data.Word( Word8, Word16, Word32 ) -import qualified Codec.Compression.Zlib as Z -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as BU -import qualified Data.ByteString.Lazy as Lb -import Foreign.Storable ( Storable ) - -import Codec.Picture.Types -import Codec.Picture.Png.Type -import Codec.Picture.Png.Export -import Codec.Picture.InternalHelper - --- | Simple structure used to hold information about Adam7 deinterlacing. --- A structure is used to avoid pollution of the module namespace. -data Adam7MatrixInfo = Adam7MatrixInfo - { adam7StartingRow :: [Int] - , adam7StartingCol :: [Int] - , adam7RowIncrement :: [Int] - , adam7ColIncrement :: [Int] - , adam7BlockHeight :: [Int] - , adam7BlockWidth :: [Int] - } - --- | The real info about the matrix. -adam7MatrixInfo :: Adam7MatrixInfo -adam7MatrixInfo = Adam7MatrixInfo - { adam7StartingRow = [0, 0, 4, 0, 2, 0, 1] - , adam7StartingCol = [0, 4, 0, 2, 0, 1, 0] - , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2] - , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1] - , adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1] - , adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1] - } - -unparsePngFilter :: Word8 -> Either String PngFilter -{-# INLINE unparsePngFilter #-} -unparsePngFilter 0 = Right FilterNone -unparsePngFilter 1 = Right FilterSub -unparsePngFilter 2 = Right FilterUp -unparsePngFilter 3 = Right FilterAverage -unparsePngFilter 4 = Right FilterPaeth -unparsePngFilter _ = Left "Invalid scanline filter" - -getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int) -{-# INLINE getBounds #-} -getBounds v = return (0, M.length v - 1) - --- | Apply a filtering method on a reduced image. Apply the filter --- on each line, using the previous line (the one above it) to perform --- some prediction on the value. -pngFiltering :: LineUnpacker s -> Int -> (Int, Int) -- ^ Image size - -> B.ByteString -> Int - -> ST s Int -pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx - | imgWidth <= 0 || imgHeight <= 0 = return initialIdx -pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do - thisLine <- M.replicate (beginZeroes + imgWidth) 0 - otherLine <- M.replicate (beginZeroes + imgWidth) 0 - let folder _ _ lineIndex !idx | lineIndex >= imgHeight = return idx - folder previousLine currentLine lineIndex !idx = do - let byte = str `BU.unsafeIndex` idx - let lineFilter = case unparsePngFilter byte of - Right FilterNone -> filterNone - Right FilterSub -> filterSub - Right FilterAverage -> filterAverage - Right FilterUp -> filterUp - Right FilterPaeth -> filterPaeth - _ -> filterNone - idx' <- lineFilter previousLine currentLine $ idx + 1 - unpacker lineIndex (stride, currentLine) - folder currentLine previousLine (lineIndex + 1) idx' - - folder thisLine otherLine (0 :: Int) initialIdx - - where stride = fromIntegral beginZeroes - lastIdx = beginZeroes + imgWidth - 1 - - -- The filter implementation are... well non-idiomatic - -- to say the least, but my benchmarks proved me one thing, - -- they are faster than mapM_, gained something like 5% with - -- a rewrite from mapM_ to this direct version - filterNone, filterSub, filterUp, filterPaeth, - filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int - filterNone !_previousLine !thisLine = inner beginZeroes - where inner idx !readIdx - | idx > lastIdx = return readIdx - | otherwise = do let byte = str `BU.unsafeIndex` readIdx - (thisLine `M.unsafeWrite` idx) byte - inner (idx + 1) $ readIdx + 1 - - filterSub !_previousLine !thisLine = inner beginZeroes - where inner idx !readIdx - | idx > lastIdx = return readIdx - | otherwise = do let byte = str `BU.unsafeIndex` readIdx - val <- thisLine `M.unsafeRead` (idx - stride) - (thisLine `M.unsafeWrite` idx) $ byte + val - inner (idx + 1) $ readIdx + 1 - - filterUp !previousLine !thisLine = inner beginZeroes - where inner idx !readIdx - | idx > lastIdx = return readIdx - | otherwise = do let byte = str `BU.unsafeIndex` readIdx - val <- previousLine `M.unsafeRead` idx - (thisLine `M.unsafeWrite` idx) $ val + byte - inner (idx + 1) $ readIdx + 1 - - filterAverage !previousLine !thisLine = inner beginZeroes - where inner idx !readIdx - | idx > lastIdx = return readIdx - | otherwise = do let byte = str `BU.unsafeIndex` readIdx - valA <- thisLine `M.unsafeRead` (idx - stride) - valB <- previousLine `M.unsafeRead` idx - let a' = fromIntegral valA - b' = fromIntegral valB - average = fromIntegral ((a' + b') `div` (2 :: Word16)) - writeVal = byte + average - (thisLine `M.unsafeWrite` idx) $ writeVal - inner (idx + 1) $ readIdx + 1 - - filterPaeth !previousLine !thisLine = inner beginZeroes - where inner idx !readIdx - | idx > lastIdx = return readIdx - | otherwise = do let byte = str `BU.unsafeIndex` readIdx - valA <- thisLine `M.unsafeRead` (idx - stride) - valC <- previousLine `M.unsafeRead` (idx - stride) - valB <- previousLine `M.unsafeRead` idx - (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC - inner (idx + 1) $ readIdx + 1 - - paeth a b c - | pa <= pb && pa <= pc = a - | pb <= pc = b - | otherwise = c - where a' = fromIntegral a :: Int - b' = fromIntegral b - c' = fromIntegral c - p = a' + b' - c' - pa = abs $ p - a' - pb = abs $ p - b' - pc = abs $ p - c' - --- | Directly stolen from the definition in the standard (on W3C page), --- pixel predictor. - -type PngLine s = M.STVector s Word8 -type LineUnpacker s = Int -> (Int, PngLine s) -> ST s () - -type StrideInfo = (Int, Int) - -type BeginOffset = (Int, Int) - - --- | Unpack lines where bit depth is 8 -byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s -byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) - (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do - (_, maxIdx) <- getBounds line - let realTop = beginTop + h * strideHeight - lineIndex = realTop * imgWidth - pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount - inner pixelIndex | pixelIndex > pixelToRead = return () - | otherwise = do - let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft - destSampleIndex = destPixelIndex * sampleCount - srcPixelIndex = pixelIndex * sampleCount + beginIdx - perPixel sample | sample >= sampleCount = return () - | otherwise = do - val <- line `M.unsafeRead` (srcPixelIndex + sample) - let writeIdx = destSampleIndex + sample - (arr `M.unsafeWrite` writeIdx) val - perPixel (sample + 1) - perPixel 0 - inner (pixelIndex + 1) - inner 0 - - --- | Unpack lines where bit depth is 1 -bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s -bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) - (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do - (_, endLine) <- getBounds line - let realTop = beginTop + h * strideHeight - lineIndex = realTop * imgWidth - (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth - subPadd | subImageRest > 0 = 1 - | otherwise = 0 - (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8 - forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do - val <- line `M.unsafeRead` (pixelIndex + beginIdx) - let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft - forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1) - - when (lineRest /= 0) - (do val <- line `M.unsafeRead` endLine - let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft - forM_ [0 .. lineRest - 1] $ \bit -> - (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1)) - - --- | Unpack lines when bit depth is 2 -twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s -twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) - (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do - (_, endLine) <- getBounds line - let realTop = beginTop + h * strideHeight - lineIndex = realTop * imgWidth - (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth - subPadd | subImageRest > 0 = 1 - | otherwise = 0 - (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4 - - forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do - val <- line `M.unsafeRead` (pixelIndex + beginIdx) - let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft - (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3 - (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3 - (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3 - (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3 - - when (lineRest /= 0) - (do val <- line `M.unsafeRead` endLine - let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft - forM_ [0 .. lineRest - 1] $ \bit -> - (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3)) - -halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s -halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) - (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do - (_, endLine) <- getBounds line - let realTop = beginTop + h * strideHeight - lineIndex = realTop * imgWidth - (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth - subPadd | subImageRest > 0 = 1 - | otherwise = 0 - (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2 - forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do - val <- line `M.unsafeRead` (pixelIndex + beginIdx) - let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft - (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF - (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF - - when (lineRest /= 0) - (do val <- line `M.unsafeRead` endLine - let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft - (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF) - -shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s -shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) - (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do - (_, maxIdx) <- getBounds line - let realTop = beginTop + h * strideHeight - lineIndex = realTop * imgWidth - pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2) - forM_ [0 .. pixelToRead] $ \pixelIndex -> do - let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft - destSampleIndex = destPixelIndex * sampleCount - srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx - forM_ [0 .. sampleCount - 1] $ \sample -> do - highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0) - lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) - let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) - writeIdx = destSampleIndex + sample - (arr `M.unsafeWrite` writeIdx) $ fullValue - --- | Transform a scanline to a bunch of bytes. Bytes are then packed --- into pixels at a further step. -scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset - -> LineUnpacker s -scanlineUnpacker8 1 = bitUnpacker -scanlineUnpacker8 2 = twoBitsUnpacker -scanlineUnpacker8 4 = halfByteUnpacker -scanlineUnpacker8 8 = byteUnpacker -scanlineUnpacker8 _ = error "Impossible bit depth" - -byteSizeOfBitLength :: Int -> Int -> Int -> Int -byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0) - where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8 - -scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) - -> B.ByteString - -> ST s () -scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = - pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return () - where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth - strideInfo | depth < 8 = 1 - | otherwise = sampleCount * (depth `div` 8) - --- | Given data and image size, recreate an image with deinterlaced --- data for PNG's adam 7 method. -adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) - -> B.ByteString -> ST s () -adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = - foldM_ (\i f -> f i) 0 subImages >> return () - where Adam7MatrixInfo { adam7StartingRow = startRows - , adam7RowIncrement = rowIncrement - , adam7StartingCol = startCols - , adam7ColIncrement = colIncrement } = adam7MatrixInfo - - subImages = - [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str - | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement - , let passWidth = sizer imgWidth beginW incrW - passHeight = sizer imgHeight beginH incrH - byteWidth = byteSizeOfBitLength depth sampleCount passWidth - ] - strideInfo | depth < 8 = 1 - | otherwise = sampleCount * (depth `div` 8) - sizer dimension begin increment - | dimension <= begin = 0 - | otherwise = outDim + (if restDim /= 0 then 1 else 0) - where (outDim, restDim) = (dimension - begin) `quotRem` increment - --- | deinterlace picture in function of the method indicated --- in the iHDR -deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16)) -deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind - , interlaceMethod = method, bitDepth = depth }) str = do - let compCount = sampleCountOfImageType imgKind - arraySize = fromIntegral $ w * h * compCount - deinterlaceFunction = case method of - PngNoInterlace -> scanLineInterleaving - PngInterlaceAdam7 -> adam7Unpack - iBitDepth = fromIntegral depth - if iBitDepth <= 8 - then do - imgArray <- M.new arraySize - let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray - deinterlaceFunction iBitDepth - (fromIntegral compCount) - (fromIntegral w, fromIntegral h) - (scanlineUnpacker8 iBitDepth (fromIntegral compCount) - mutableImage) - str - Left <$> V.unsafeFreeze imgArray - - else do - imgArray <- M.new arraySize - let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray - deinterlaceFunction iBitDepth - (fromIntegral compCount) - (fromIntegral w, fromIntegral h) - (shortUnpacker (fromIntegral compCount) mutableImage) - str - Right <$> V.unsafeFreeze imgArray - -generateGreyscalePalette :: Word8 -> PngPalette -generateGreyscalePalette times = Image possibilities 0 vec - where possibilities = 2 ^ times - 1 - vec = V.fromListN ((fromIntegral possibilities + 1) * 3) $ concat pixels - pixels = [[i, i, i] | n <- [0 .. possibilities] - , let i = fromIntegral $ n * (255 `div` possibilities)] - -sampleCountOfImageType :: PngImageType -> Word32 -sampleCountOfImageType PngGreyscale = 1 -sampleCountOfImageType PngTrueColour = 3 -sampleCountOfImageType PngIndexedColor = 1 -sampleCountOfImageType PngGreyscaleWithAlpha = 2 -sampleCountOfImageType PngTrueColourWithAlpha = 4 - -paletteRGBA1, paletteRGBA2, paletteRGBA4 :: PngPalette -paletteRGBA1 = generateGreyscalePalette 1 -paletteRGBA2 = generateGreyscalePalette 2 -paletteRGBA4 = generateGreyscalePalette 4 - -{-# INLINE bounds #-} -bounds :: Storable a => V.Vector a -> (Int, Int) -bounds v = (0, V.length v - 1) - -applyPalette :: PngPalette -> V.Vector Word8 -> V.Vector Word8 -applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels - where (_, initSize) = bounds img - pixels = concat [[r, g, b] | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] - -applyPaletteWithTransparency :: PngPalette -> Word8 -> V.Vector Word8 -> V.Vector Word8 -applyPaletteWithTransparency pal transp img = V.fromListN ((initSize + 1) * 4) pixels - where (_, initSize) = bounds img - pixels = concat [ if ipx == transp then [0, 0, 0, 0] else [r, g, b, 255] - | ipx <- V.toList img - , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] - --- | Transform a raw png image to an image, without modifying the --- underlying pixel type. If the image is greyscale and < 8 bits, --- a transformation to RGBA8 is performed. This should change --- in the future. --- The resulting image let you manage the pixel types. --- --- This function can output the following pixel types : --- --- * PixelY8 --- --- * PixelY16 --- --- * PixelYA8 --- --- * PixelYA16 --- --- * PixelRGB8 --- --- * PixelRGB16 --- --- * PixelRGBA8 --- --- * PixelRGBA16 --- -decodePng :: B.ByteString -> Either String DynamicImage -decodePng byte = do - rawImg <- runGetStrict get byte - let ihdr@(PngIHdr { width = w, height = h }) = header rawImg - compressedImageData = - Lb.concat [chunkData chunk | chunk <- chunks rawImg - , chunkType chunk == iDATSignature] - zlibHeaderSize = 1 {- compression method/flags code -} - + 1 {- Additional flags/check bits -} - + 4 {-CRC-} - - toImage const1 _const2 (Left a) = - Right . const1 $ Image (fromIntegral w) (fromIntegral h) a - toImage _const1 const2 (Right a) = - Right . const2 $ Image (fromIntegral w) (fromIntegral h) a - - palette8 palette [(Lb.uncons -> Just (c,_))] (Left img) = - Right . ImageRGBA8 - . Image (fromIntegral w) (fromIntegral h) - $ applyPaletteWithTransparency palette c img - - palette8 palette _ (Left img) = - Right . ImageRGB8 - . Image (fromIntegral w) (fromIntegral h) - $ applyPalette palette img - - palette8 _ _ (Right _) = Left "Invalid bit depth for paleted image" - - transparencyColor = - [ chunkData chunk | chunk <- chunks rawImg - , chunkType chunk == tRNSSignature ] - - unparse _ t PngGreyscale bytes - | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) t PngIndexedColor bytes - | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) t PngIndexedColor bytes - | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) t PngIndexedColor bytes - | otherwise = toImage ImageY8 ImageY16 $ runST stArray - where stArray = deinterlacer ihdr bytes - - unparse Nothing _ PngIndexedColor _ = Left "no valid palette found" - unparse _ _ PngTrueColour bytes = - toImage ImageRGB8 ImageRGB16 $ runST stArray - where stArray = deinterlacer ihdr bytes - unparse _ _ PngGreyscaleWithAlpha bytes = - toImage ImageYA8 ImageYA16 $ runST stArray - where stArray = deinterlacer ihdr bytes - unparse _ _ PngTrueColourWithAlpha bytes = - toImage ImageRGBA8 ImageRGBA16 $ runST stArray - where stArray = deinterlacer ihdr bytes - unparse (Just plte) transparency PngIndexedColor bytes = - palette8 plte transparency $ runST stArray - where stArray = deinterlacer ihdr bytes - - if Lb.length compressedImageData <= zlibHeaderSize - then Left "Invalid data size" - else let imgData = Z.decompress compressedImageData - parseableData = B.concat $ Lb.toChunks imgData - palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of - Nothing -> Nothing - Just p -> case parsePalette p of - Left _ -> Nothing - Right plte -> Just plte - in unparse palette transparencyColor (colourType ihdr) parseableData - diff --git a/Codec/Picture/Png/Export.hs b/Codec/Picture/Png/Export.hs deleted file mode 100644 --- a/Codec/Picture/Png/Export.hs +++ /dev/null @@ -1,163 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE TypeFamilies #-} --- | Module implementing a basic png export, no filtering is applyed, but --- export at least valid images. -module Codec.Picture.Png.Export( PngSavable( .. ) - , writePng - , encodeDynamicPng - , writeDynamicPng - ) where - -import Control.Monad( forM_ ) -import Control.Monad.ST( ST, runST ) -import Data.Bits( unsafeShiftR, (.&.) ) -import Data.Binary( encode ) -import Data.Word(Word8, Word16) -import qualified Codec.Compression.Zlib as Z -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Lb - -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Types -import Codec.Picture.Png.Type -import Codec.Picture.VectorByteConversion( blitVector ) - --- | Encode an image into a png if possible. -class PngSavable a where - -- | Transform an image into a png encoded bytestring, ready - -- to be written as a file. - encodePng :: Image a -> Lb.ByteString - -preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr -preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr - { width = fromIntegral w - , height = fromIntegral h - , bitDepth = depth - , colourType = imgType - , compressionMethod = 0 - , filterMethod = 0 - , interlaceMethod = PngNoInterlace - } - --- | Helper function to directly write an image as a png on disk. -writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () -writePng path img = Lb.writeFile path $ encodePng img - -endChunk :: PngRawChunk -endChunk = PngRawChunk { chunkLength = 0 - , chunkType = iENDSignature - , chunkCRC = pngComputeCrc [iENDSignature] - , chunkData = Lb.empty - } - - -prepareIDatChunk :: Lb.ByteString -> PngRawChunk -prepareIDatChunk imgData = PngRawChunk - { chunkLength = fromIntegral $ Lb.length imgData - , chunkType = iDATSignature - , chunkCRC = pngComputeCrc [iDATSignature, imgData] - , chunkData = imgData - } - -genericEncode16BitsPng :: (PixelBaseComponent a ~ Word16) - => PngImageType -> Int -> Image a -> Lb.ByteString -genericEncode16BitsPng imgKind compCount - image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = - encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]} - where hdr = preparePngHeader image imgKind 16 - zero = B.singleton 0 - - lineSize = compCount * w - toByteString vec = blitVector vec 0 (lineSize * 2) - encodeLine line = toByteString $ runST $ do - finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) - let baseIndex = line * lineSize - forM_ [0 .. lineSize - 1] $ \ix -> do - let v = arr `VS.unsafeIndex` (baseIndex + ix) - high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF - low = fromIntegral $ v .&. 0xFF - - (finalVec `M.unsafeWrite` (ix * 2 + 0)) high - (finalVec `M.unsafeWrite` (ix * 2 + 1)) low - - VS.unsafeFreeze finalVec - - imgEncodedData = Z.compress . Lb.fromChunks - $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] - - -genericEncodePng :: (PixelBaseComponent a ~ Word8) - => PngImageType -> Int -> Image a -> Lb.ByteString -genericEncodePng imgKind compCount - image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = - encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]} - where hdr = preparePngHeader image imgKind 8 - zero = B.singleton 0 - - lineSize = compCount * w - encodeLine line = blitVector arr (line * lineSize) lineSize - imgEncodedData = Z.compress . Lb.fromChunks - $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] - -instance PngSavable PixelRGBA8 where - encodePng = genericEncodePng PngTrueColourWithAlpha 4 - -instance PngSavable PixelRGB8 where - encodePng = genericEncodePng PngTrueColour 3 - -instance PngSavable Pixel8 where - encodePng = genericEncodePng PngGreyscale 1 - -instance PngSavable PixelYA8 where - encodePng = genericEncodePng PngGreyscaleWithAlpha 2 - -instance PngSavable PixelYA16 where - encodePng = genericEncode16BitsPng PngGreyscaleWithAlpha 2 - -instance PngSavable Pixel16 where - encodePng = genericEncode16BitsPng PngGreyscale 1 - -instance PngSavable PixelRGB16 where - encodePng = genericEncode16BitsPng PngTrueColour 3 - -instance PngSavable PixelRGBA16 where - encodePng = genericEncode16BitsPng PngTrueColourWithAlpha 4 - --- | Write a dynamic image in a .png image file if possible. --- The same restriction as encodeDynamicPng apply. -writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) -writeDynamicPng path img = case encodeDynamicPng img of - Left err -> return $ Left err - Right b -> Lb.writeFile path b >> return (Right True) - --- | Encode a dynamic image in bmp if possible, supported pixel type are : --- --- - Y8 --- --- - Y16 --- --- - YA8 --- --- - YA16 --- --- - RGB8 --- --- - RGB16 --- --- - RGBA8 --- --- - RGBA16 --- -encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString -encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img -encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img -encodeDynamicPng (ImageY8 img) = Right $ encodePng img -encodeDynamicPng (ImageY16 img) = Right $ encodePng img -encodeDynamicPng (ImageYA8 img) = Right $ encodePng img -encodeDynamicPng (ImageYA16 img) = Right $ encodePng img -encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img -encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img -encodeDynamicPng _ = Left "Unsupported image format for PNG export" diff --git a/Codec/Picture/Png/Type.hs b/Codec/Picture/Png/Type.hs deleted file mode 100644 --- a/Codec/Picture/Png/Type.hs +++ /dev/null @@ -1,329 +0,0 @@ --- | Low level png module, you should import 'Codec.Picture.Png' instead. -module Codec.Picture.Png.Type( PngIHdr( .. ) - , PngFilter( .. ) - , PngInterlaceMethod( .. ) - , PngPalette - , PngImageType( .. ) - , parsePalette - , pngComputeCrc - , pLTESignature - , iDATSignature - , iENDSignature - , tRNSSignature - -- * Low level types - , ChunkSignature - , PngRawImage( .. ) - , PngChunk( .. ) - , PngRawChunk( .. ) - , PngLowLevel( .. ) - ) where - -import Control.Applicative( (<$>) ) -import Control.Monad( when, replicateM ) -import Data.Bits( xor, (.&.), unsafeShiftR ) -import Data.Binary( Binary(..), Get, get ) -import Data.Binary.Get( getWord8 - , getWord32be - , getLazyByteString - ) -import Data.Binary.Put( runPut - , putWord8 - , putWord32be - , putLazyByteString - ) -import Data.Vector.Unboxed( Vector, fromListN, (!) ) -import qualified Data.Vector.Storable as V -import Data.List( foldl' ) -import Data.Word( Word32, Word8 ) -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Lazy.Char8 as LS - -import Codec.Picture.Types -import Codec.Picture.InternalHelper - --------------------------------------------------- ----- Types --------------------------------------------------- - --- | Value used to identify a png chunk, must be 4 bytes long. -type ChunkSignature = L.ByteString - --- | Generic header used in PNG images. -data PngIHdr = PngIHdr - { width :: Word32 -- ^ Image width in number of pixel - , height :: Word32 -- ^ Image height in number of pixel - , bitDepth :: Word8 -- ^ Number of bit per sample - , colourType :: PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) - , compressionMethod :: Word8 -- ^ Compression method used - , filterMethod :: Word8 -- ^ Must be 0 - , interlaceMethod :: PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) - } - deriving Show - --- | What kind of information is encoded in the IDAT section --- of the PngFile -data PngImageType = - PngGreyscale - | PngTrueColour - | PngIndexedColor - | PngGreyscaleWithAlpha - | PngTrueColourWithAlpha - deriving Show - --- | Raw parsed image which need to be decoded. -data PngRawImage = PngRawImage - { header :: PngIHdr - , chunks :: [PngRawChunk] - } - --- | Palette with indices beginning at 0 to elemcount - 1 -type PngPalette = Image PixelRGB8 - --- | Parse a palette from a png chunk. -parsePalette :: PngRawChunk -> Either String PngPalette -parsePalette plte - | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" - | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels - where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get - pixelCount = fromIntegral $ chunkLength plte `div` 3 - pixels = runGet pixelUnpacker (chunkData plte) - --- | Data structure during real png loading/parsing -data PngRawChunk = PngRawChunk - { chunkLength :: Word32 - , chunkType :: ChunkSignature - , chunkCRC :: Word32 - , chunkData :: L.ByteString - } - --- | PNG chunk representing some extra information found in the parsed file. -data PngChunk = PngChunk - { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk - , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. - } - --- | Low level access to PNG information -data PngLowLevel a = PngLowLevel - { pngImage :: Image a -- ^ The real uncompressed image - , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. - } - --- | The pixels value should be : --- +---+---+ --- | c | b | --- +---+---+ --- | a | x | --- +---+---+ --- x being the current filtered pixel -data PngFilter = - -- | Filt(x) = Orig(x), Recon(x) = Filt(x) - FilterNone - -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) - | FilterSub - -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) - | FilterUp - -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), - -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) - | FilterAverage - -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), - -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) - | FilterPaeth - deriving (Enum, Show) - --- | Different known interlace methods for PNG image -data PngInterlaceMethod = - -- | No interlacing, basic data ordering, line by line - -- from left to right. - PngNoInterlace - - -- | Use the Adam7 ordering, see `adam7Reordering` - | PngInterlaceAdam7 - deriving (Enum, Show) - --------------------------------------------------- ----- Instances --------------------------------------------------- -instance Binary PngFilter where - put = putWord8 . toEnum . fromEnum - get = getWord8 >>= \w -> case w of - 0 -> return FilterNone - 1 -> return FilterSub - 2 -> return FilterUp - 3 -> return FilterAverage - 4 -> return FilterPaeth - _ -> fail "Invalid scanline filter" - -instance Binary PngRawImage where - put img = do - putLazyByteString pngSignature - put $ header img - mapM_ put $ chunks img - - get = parseRawPngImage - -instance Binary PngRawChunk where - put chunk = do - putWord32be $ chunkLength chunk - putLazyByteString $ chunkType chunk - when (chunkLength chunk /= 0) - (putLazyByteString $ chunkData chunk) - putWord32be $ chunkCRC chunk - - get = do - size <- getWord32be - chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature) - imgData <- if size == 0 - then return L.empty - else getLazyByteString (fromIntegral size) - crc <- getWord32be - - let computedCrc = pngComputeCrc [chunkSig, imgData] - when (computedCrc `xor` crc /= 0) - (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " - ++ show crc) - return PngRawChunk { - chunkLength = size, - chunkData = imgData, - chunkCRC = crc, - chunkType = chunkSig - } - -instance Binary PngIHdr where - put hdr = do - putWord32be 13 - let inner = runPut $ do - putLazyByteString iHDRSignature - putWord32be $ width hdr - putWord32be $ height hdr - putWord8 $ bitDepth hdr - put $ colourType hdr - put $ compressionMethod hdr - put $ filterMethod hdr - put $ interlaceMethod hdr - crc = pngComputeCrc [inner] - putLazyByteString inner - putWord32be crc - - get = do - _size <- getWord32be - ihdrSig <- getLazyByteString (L.length iHDRSignature) - when (ihdrSig /= iHDRSignature) - (fail "Invalid PNG file, wrong ihdr") - w <- getWord32be - h <- getWord32be - depth <- get - colorType <- get - compression <- get - filtermethod <- get - interlace <- get - _crc <- getWord32be - return PngIHdr { - width = w, - height = h, - bitDepth = depth, - colourType = colorType, - compressionMethod = compression, - filterMethod = filtermethod, - interlaceMethod = interlace - } - --- | Parse method for a png chunk, without decompression. -parseChunks :: Get [PngRawChunk] -parseChunks = do - chunk <- get - - if chunkType chunk == iENDSignature - then return [chunk] - else (chunk:) <$> parseChunks - - -instance Binary PngInterlaceMethod where - get = getWord8 >>= \w -> case w of - 0 -> return PngNoInterlace - 1 -> return PngInterlaceAdam7 - _ -> fail "Invalid interlace method" - - put PngNoInterlace = putWord8 0 - put PngInterlaceAdam7 = putWord8 1 - --- | Implementation of the get method for the PngRawImage, --- unpack raw data, without decompressing it. -parseRawPngImage :: Get PngRawImage -parseRawPngImage = do - sig <- getLazyByteString (L.length pngSignature) - when (sig /= pngSignature) - (fail "Invalid PNG file, signature broken") - - ihdr <- get - - chunkList <- parseChunks - return PngRawImage { header = ihdr, chunks = chunkList } - --------------------------------------------------- ----- functions --------------------------------------------------- - --- | Signature signalling that the following data will be a png image --- in the png bit stream -pngSignature :: ChunkSignature -pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] - --- | Helper function to help pack signatures. -signature :: String -> ChunkSignature -signature = LS.pack - --- | Signature for the header chunk of png (must be the first) -iHDRSignature :: ChunkSignature -iHDRSignature = signature "IHDR" - --- | Signature for a palette chunk in the pgn file. Must --- occure before iDAT. -pLTESignature :: ChunkSignature -pLTESignature = signature "PLTE" - --- | Signature for a data chuck (with image parts in it) -iDATSignature :: ChunkSignature -iDATSignature = signature "IDAT" - --- | Signature for the last chunk of a png image, telling --- the end. -iENDSignature :: ChunkSignature -iENDSignature = signature "IEND" - -tRNSSignature :: ChunkSignature -tRNSSignature = signature "tRNS" - -instance Binary PngImageType where - put PngGreyscale = putWord8 0 - put PngTrueColour = putWord8 2 - put PngIndexedColor = putWord8 3 - put PngGreyscaleWithAlpha = putWord8 4 - put PngTrueColourWithAlpha = putWord8 6 - - get = get >>= imageTypeOfCode - -imageTypeOfCode :: Word8 -> Get PngImageType -imageTypeOfCode 0 = return PngGreyscale -imageTypeOfCode 2 = return PngTrueColour -imageTypeOfCode 3 = return PngIndexedColor -imageTypeOfCode 4 = return PngGreyscaleWithAlpha -imageTypeOfCode 6 = return PngTrueColourWithAlpha -imageTypeOfCode _ = fail "Invalid png color code" - --- | From the Annex D of the png specification. -pngCrcTable :: Vector Word32 -pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] - where zero = 0 :: Int -- To avoid defaulting to Integer - updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1) - | otherwise = c `unsafeShiftR` 1 - magicConstant = 0xedb88320 :: Word32 - --- | Compute the CRC of a raw buffer, as described in annex D of the PNG --- specification. -pngComputeCrc :: [L.ByteString] -> Word32 -pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat - where updateCrc crc val = - let u32Val = fromIntegral val - lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) - in lutVal `xor` (crc `unsafeShiftR` 8) - diff --git a/Codec/Picture/Saving.hs b/Codec/Picture/Saving.hs deleted file mode 100644 --- a/Codec/Picture/Saving.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} --- | Helper functions to save dynamic images to other file format --- with automatic color space/sample format conversion done automatically. -module Codec.Picture.Saving( imageToJpg - , imageToPng - , imageToBitmap - , imageToTiff - , imageToRadiance - ) where - -import Data.Bits( unsafeShiftR ) -import Data.Word( Word8, Word16 ) -import qualified Data.ByteString.Lazy as L -import Codec.Picture.Bitmap -import Codec.Picture.Jpg -import Codec.Picture.Png -import Codec.Picture.HDR -import Codec.Picture.Types -import Codec.Picture.Tiff - -import qualified Data.Vector.Storable as V - -componentToLDR :: Float -> Word8 -componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 - -toStandardDef :: Image PixelRGBF -> Image PixelRGB8 -toStandardDef img = pixelMap pixelConverter img - where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b - where r = componentToLDR rf - g = componentToLDR gf - b = componentToLDR bf - -greyScaleToStandardDef :: Image PixelF -> Image Pixel8 -greyScaleToStandardDef = pixelMap componentToLDR - -from16to8 :: ( PixelBaseComponent source ~ Word16 - , PixelBaseComponent dest ~ Word8 ) - => Image source -> Image dest -from16to8 Image { imageWidth = w, imageHeight = h - , imageData = arr } = Image w h transformed - where transformed = V.map toWord8 arr - toWord8 v = fromIntegral (v `unsafeShiftR` 8) - -from16toFloat :: ( PixelBaseComponent source ~ Word16 - , PixelBaseComponent dest ~ Float ) - => Image source -> Image dest -from16toFloat Image { imageWidth = w, imageHeight = h - , imageData = arr } = Image w h transformed - where transformed = V.map toWord8 arr - toWord8 v = fromIntegral v / 65536.0 - --- | This function will try to do anything to encode an image --- as RADIANCE, make all color conversion and such. Equivalent --- of 'decodeImage' for radiance encoding -imageToRadiance :: DynamicImage -> L.ByteString -imageToRadiance (ImageCMYK8 img) = - imageToRadiance . ImageRGB8 $ convertImage img -imageToRadiance (ImageCMYK16 img) = - imageToRadiance . ImageRGB16 $ convertImage img -imageToRadiance (ImageYCbCr8 img) = - imageToRadiance . ImageRGB8 $ convertImage img -imageToRadiance (ImageRGB8 img) = - imageToRadiance . ImageRGBF $ promoteImage img -imageToRadiance (ImageRGBF img) = encodeHDR img -imageToRadiance (ImageRGBA8 img) = - imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img -imageToRadiance (ImageY8 img) = - imageToRadiance . ImageRGB8 $ promoteImage img -imageToRadiance (ImageYF img) = - imageToRadiance . ImageRGBF $ promoteImage img -imageToRadiance (ImageYA8 img) = - imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img -imageToRadiance (ImageY16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf v = PixelRGBF val val val - where val = fromIntegral v / 65536.0 - -imageToRadiance (ImageYA16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf (PixelYA16 v _) = PixelRGBF val val val - where val = fromIntegral v / 65536.0 -imageToRadiance (ImageRGB16 img) = - imageToRadiance . ImageRGBF $ from16toFloat img -imageToRadiance (ImageRGBA16 img) = - imageToRadiance . ImageRGBF $ pixelMap toRgbf img - where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) - where f v = fromIntegral v / 65536.0 - --- | This function will try to do anything to encode an image --- as JPEG, make all color conversion and such. Equivalent --- of 'decodeImage' for jpeg encoding -imageToJpg :: Int -> DynamicImage -> L.ByteString -imageToJpg quality dynImage = - let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) - in case dynImage of - ImageYCbCr8 img -> encodeAtQuality img - ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img - ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img - ImageRGB8 img -> encodeAtQuality (convertImage img) - ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img - ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) - ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img - ImageY8 img -> encodeAtQuality . convertImage - $ (promoteImage img :: Image PixelRGB8) - ImageYA8 img -> encodeAtQuality $ - convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8) - ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img - ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img - ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img - ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img - --- | This function will try to do anything to encode an image --- as PNG, make all color conversion and such. Equivalent --- of 'decodeImage' for PNG encoding -imageToPng :: DynamicImage -> L.ByteString -imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) -imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) -imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) -imageToPng (ImageRGB8 img) = encodePng img -imageToPng (ImageRGBF img) = encodePng $ toStandardDef img -imageToPng (ImageRGBA8 img) = encodePng img -imageToPng (ImageY8 img) = encodePng img -imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img -imageToPng (ImageYA8 img) = encodePng img -imageToPng (ImageY16 img) = encodePng img -imageToPng (ImageYA16 img) = encodePng img -imageToPng (ImageRGB16 img) = encodePng img -imageToPng (ImageRGBA16 img) = encodePng img - --- | This function will try to do anything to encode an image --- as a Tiff, make all color conversion and such. Equivalent --- of 'decodeImage' for Tiff encoding -imageToTiff :: DynamicImage -> L.ByteString -imageToTiff (ImageYCbCr8 img) = encodeTiff img -imageToTiff (ImageCMYK8 img) = encodeTiff img -imageToTiff (ImageCMYK16 img) = encodeTiff img -imageToTiff (ImageRGB8 img) = encodeTiff img -imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img -imageToTiff (ImageRGBA8 img) = encodeTiff img -imageToTiff (ImageY8 img) = encodeTiff img -imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img -imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img -imageToTiff (ImageY16 img) = encodeTiff img -imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img -imageToTiff (ImageRGB16 img) = encodeTiff img -imageToTiff (ImageRGBA16 img) = encodeTiff img - --- | This function will try to do anything to encode an image --- as bitmap, make all color conversion and such. Equivalent --- of 'decodeImage' for Bitmap encoding -imageToBitmap :: DynamicImage -> L.ByteString -imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) -imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) -imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img -imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img -imageToBitmap (ImageRGB8 img) = encodeBitmap img -imageToBitmap (ImageRGBA8 img) = encodeBitmap img -imageToBitmap (ImageY8 img) = encodeBitmap img -imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img -imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) -imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img -imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img -imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img -imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img - diff --git a/Codec/Picture/Tiff.hs b/Codec/Picture/Tiff.hs deleted file mode 100644 --- a/Codec/Picture/Tiff.hs +++ /dev/null @@ -1,1285 +0,0 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} --- | Module implementing TIFF decoding. --- --- Supported compression schemes : --- --- * Uncompressed --- --- * PackBits --- --- * LZW --- --- Supported bit depth : --- --- * 2 bits --- --- * 4 bits --- --- * 8 bits --- --- * 16 bits --- -module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where - -import Control.Applicative( (<$>), (<*>), pure ) -import Control.Monad( when, replicateM, foldM_ ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.Writer.Strict( execWriter, tell, Writer ) -import Data.Int( Int8 ) -import Data.Word( Word8, Word16 ) -import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) -import Data.Binary( Binary( .. ) ) -import Data.Binary.Get( Get - , getWord16le, getWord16be - , getWord32le, getWord32be - , bytesRead - , skip - , getByteString - ) -import Data.Binary.Put( Put, runPut - , putWord16le, putWord16be - , putWord32le, putWord32be - , putByteString - ) - -import Data.List( sortBy, mapAccumL ) -import qualified Data.Vector as V -import qualified Data.Vector.Storable as VS -import qualified Data.Vector.Storable.Mutable as M -import Data.Word( Word32 ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Lb -import qualified Data.ByteString.Unsafe as BU - -import Foreign.Storable( sizeOf ) - -import Codec.Picture.InternalHelper -import Codec.Picture.BitWriter -import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.VectorByteConversion( toByteString ) - -data Endianness = EndianLittle - | EndianBig - deriving (Eq, Show) - -instance Binary Endianness where - put EndianLittle = putWord16le 0x4949 - put EndianBig = putWord16le 0x4D4D - - get = do - tag <- getWord16le - case tag of - 0x4949 -> return EndianLittle - 0x4D4D -> return EndianBig - _ -> fail "Invalid endian tag value" - --- | Because having a polymorphic get with endianness is to nice --- to pass on, introducing this helper type class, which is just --- a superset of Binary, but formalising a parameter passing --- into it. -class BinaryParam a b where - getP :: a -> Get b - putP :: a -> b -> Put - -data TiffHeader = TiffHeader - { hdrEndianness :: !Endianness - , hdrOffset :: {-# UNPACK #-} !Word32 - } - deriving (Eq, Show) - -instance BinaryParam Endianness Word16 where - putP EndianLittle = putWord16le - putP EndianBig = putWord16be - - getP EndianLittle = getWord16le - getP EndianBig = getWord16be - -instance BinaryParam Endianness Word32 where - putP EndianLittle = putWord32le - putP EndianBig = putWord32be - - getP EndianLittle = getWord32le - getP EndianBig = getWord32be - -instance Binary TiffHeader where - put hdr = do - let endian = hdrEndianness hdr - put endian - putP endian (42 :: Word16) - putP endian $ hdrOffset hdr - - get = do - endian <- get - magic <- getP endian - let magicValue = 42 :: Word16 - when (magic /= magicValue) - (fail "Invalid TIFF magic number") - TiffHeader endian <$> getP endian - -data TiffPlanarConfiguration = - PlanarConfigContig -- = 1 - | PlanarConfigSeparate -- = 2 - -planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration -planarConfgOfConstant 0 = pure PlanarConfigContig -planarConfgOfConstant 1 = pure PlanarConfigContig -planarConfgOfConstant 2 = pure PlanarConfigSeparate -planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" - -constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 -constantToPlaneConfiguration PlanarConfigContig = 1 -constantToPlaneConfiguration PlanarConfigSeparate = 2 - -data TiffCompression = - CompressionNone -- 1 - | CompressionModifiedRLE -- 2 - | CompressionLZW -- 5 - | CompressionJPEG -- 6 - | CompressionPackBit -- 32273 - -data IfdType = TypeByte - | TypeAscii - | TypeShort - | TypeLong - | TypeRational - | TypeSByte - | TypeUndefined - | TypeSignedShort - | TypeSignedLong - | TypeSignedRational - | TypeFloat - | TypeDouble - -instance BinaryParam Endianness IfdType where - getP endianness = getP endianness >>= conv - where - conv :: Word16 -> Get IfdType - conv 1 = return TypeByte - conv 2 = return TypeAscii - conv 3 = return TypeShort - conv 4 = return TypeLong - conv 5 = return TypeRational - conv 6 = return TypeSByte - conv 7 = return TypeUndefined - conv 8 = return TypeSignedShort - conv 9 = return TypeSignedLong - conv 10 = return TypeSignedRational - conv 11 = return TypeFloat - conv 12 = return TypeDouble - conv _ = fail "Invalid TIF directory type" - - putP endianness = putP endianness . conv - where - conv :: IfdType -> Word16 - conv TypeByte = 1 - conv TypeAscii = 2 - conv TypeShort = 3 - conv TypeLong = 4 - conv TypeRational = 5 - conv TypeSByte = 6 - conv TypeUndefined = 7 - conv TypeSignedShort = 8 - conv TypeSignedLong = 9 - conv TypeSignedRational = 10 - conv TypeFloat = 11 - conv TypeDouble = 12 - -data TiffTag = TagPhotometricInterpretation - | TagCompression -- ^ Short type - | TagImageWidth -- ^ Short or long type - | TagImageLength -- ^ Short or long type - | TagXResolution -- ^ Rational type - | TagYResolution -- ^ Rational type - | TagResolutionUnit -- ^ Short type - | TagRowPerStrip -- ^ Short or long type - | TagStripByteCounts -- ^ Short or long - | TagStripOffsets -- ^ Short or long - | TagBitsPerSample -- ^ Short - | TagColorMap -- ^ Short - | TagTileWidth - | TagTileLength - | TagTileOffset - | TagTileByteCount - | TagSamplesPerPixel -- ^ Short - | TagArtist - | TagDocumentName - | TagSoftware - | TagPlanarConfiguration -- ^ Short - | TagOrientation - | TagSampleFormat -- ^ Short - | TagInkSet - | TagSubfileType - | TagFillOrder - | TagYCbCrCoeff - | TagYCbCrSubsampling - | TagYCbCrPositioning - | TagReferenceBlackWhite - | TagXPosition - | TagYPosition - | TagExtraSample - | TagImageDescription - - | TagJpegProc - | TagJPEGInterchangeFormat - | TagJPEGInterchangeFormatLength - | TagJPEGRestartInterval - | TagJPEGLosslessPredictors - | TagJPEGPointTransforms - | TagJPEGQTables - | TagJPEGDCTables - | TagJPEGACTables - - | TagUnknown Word16 - deriving (Eq, Show) - -tagOfWord16 :: Word16 -> TiffTag -tagOfWord16 = aux - where aux 255 = TagSubfileType - aux 256 = TagImageWidth - aux 257 = TagImageLength - aux 258 = TagBitsPerSample - aux 259 = TagCompression - aux 262 = TagPhotometricInterpretation - aux 266 = TagFillOrder - aux 269 = TagDocumentName - aux 270 = TagImageDescription - aux 273 = TagStripOffsets - aux 274 = TagOrientation - aux 277 = TagSamplesPerPixel - aux 278 = TagRowPerStrip - aux 279 = TagStripByteCounts - aux 282 = TagXResolution - aux 283 = TagYResolution - aux 284 = TagPlanarConfiguration - aux 286 = TagXPosition - aux 287 = TagYPosition - aux 296 = TagResolutionUnit - aux 305 = TagSoftware - aux 315 = TagArtist - aux 320 = TagColorMap - aux 322 = TagTileWidth - aux 323 = TagTileLength - aux 324 = TagTileOffset - aux 325 = TagTileByteCount - aux 332 = TagInkSet - aux 338 = TagExtraSample - aux 339 = TagSampleFormat - aux 529 = TagYCbCrCoeff - aux 512 = TagJpegProc - aux 513 = TagJPEGInterchangeFormat - aux 514 = TagJPEGInterchangeFormatLength - aux 515 = TagJPEGRestartInterval - aux 517 = TagJPEGLosslessPredictors - aux 518 = TagJPEGPointTransforms - aux 519 = TagJPEGQTables - aux 520 = TagJPEGDCTables - aux 521 = TagJPEGACTables - aux 530 = TagYCbCrSubsampling - aux 531 = TagYCbCrPositioning - aux 532 = TagReferenceBlackWhite - aux v = TagUnknown v - -word16OfTag :: TiffTag -> Word16 -word16OfTag = aux - where aux TagSubfileType = 255 - aux TagImageWidth = 256 - aux TagImageLength = 257 - aux TagBitsPerSample = 258 - aux TagCompression = 259 - aux TagPhotometricInterpretation = 262 - aux TagFillOrder = 266 - aux TagDocumentName = 269 - aux TagImageDescription = 270 - aux TagStripOffsets = 273 - aux TagOrientation = 274 - aux TagSamplesPerPixel = 277 - aux TagRowPerStrip = 278 - aux TagStripByteCounts = 279 - aux TagXResolution = 282 - aux TagYResolution = 283 - aux TagPlanarConfiguration = 284 - aux TagXPosition = 286 - aux TagYPosition = 287 - aux TagResolutionUnit = 296 - aux TagSoftware = 305 - aux TagArtist = 315 - aux TagColorMap = 320 - aux TagTileWidth = 322 - aux TagTileLength = 323 - aux TagTileOffset = 324 - aux TagTileByteCount = 325 - aux TagInkSet = 332 - aux TagExtraSample = 338 - aux TagSampleFormat = 339 - aux TagYCbCrCoeff = 529 - aux TagJpegProc = 512 - aux TagJPEGInterchangeFormat = 513 - aux TagJPEGInterchangeFormatLength = 514 - aux TagJPEGRestartInterval = 515 - aux TagJPEGLosslessPredictors = 517 - aux TagJPEGPointTransforms = 518 - aux TagJPEGQTables = 519 - aux TagJPEGDCTables = 520 - aux TagJPEGACTables = 521 - aux TagYCbCrSubsampling = 530 - aux TagYCbCrPositioning = 531 - aux TagReferenceBlackWhite = 532 - aux (TagUnknown v) = v - -instance BinaryParam Endianness TiffTag where - getP endianness = tagOfWord16 <$> getP endianness - putP endianness = putP endianness . word16OfTag - -data ExtendedDirectoryData = - ExtendedDataNone - | ExtendedDataAscii !B.ByteString - | ExtendedDataShort !(V.Vector Word16) - | ExtendedDataLong !(V.Vector Word32) - deriving (Eq, Show) - -instance BinaryParam (Endianness, ImageFileDirectory) ExtendedDirectoryData where - putP (endianness, _) = dump - where - dump ExtendedDataNone = pure () - dump (ExtendedDataAscii bstr) = putByteString bstr - dump (ExtendedDataShort shorts) = V.mapM_ (putP endianness) shorts - dump (ExtendedDataLong longs) = V.mapM_ (putP endianness) longs - - getP (endianness, ifd) = fetcher ifd - where - align ImageFileDirectory { ifdOffset = offset } = do - readed <- bytesRead - skip . fromIntegral $ fromIntegral offset - readed - - getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - getVec count = V.replicateM (fromIntegral count) - - fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = - align ifd >> (ExtendedDataAscii <$> getByteString (fromIntegral count)) - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = - pure . ExtendedDataShort $ V.fromListN 2 valList - where high = fromIntegral $ ofs `unsafeShiftR` 16 - low = fromIntegral $ ofs .&. 0xFFFF - valList = case endianness of - EndianLittle -> [low, high] - EndianBig -> [high, low] - fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = - align ifd >> (ExtendedDataShort <$> getVec count getE) - fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = - align ifd >> (ExtendedDataLong <$> getVec count getE) - fetcher _ = pure ExtendedDataNone - -data TiffSampleFormat = - TiffSampleUint - | TiffSampleInt - | TiffSampleDouble - | TiffSampleUnknown - deriving Eq - -unpackSampleFormat :: Word32 -> Get TiffSampleFormat -unpackSampleFormat = aux - where - aux 1 = pure TiffSampleUint - aux 2 = pure TiffSampleInt - aux 3 = pure TiffSampleDouble - aux 4 = pure TiffSampleUnknown - aux v = fail $ "Undefined data format (" ++ show v ++ ")" - -data ImageFileDirectory = ImageFileDirectory - { ifdIdentifier :: !TiffTag - , ifdType :: !IfdType - , ifdCount :: !Word32 - , ifdOffset :: !Word32 - , ifdExtended :: !ExtendedDirectoryData - } - -unLong :: String -> ExtendedDirectoryData -> Get (V.Vector Word32) -unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v -unLong _ (ExtendedDataLong v) = pure v -unLong errMessage _ = fail errMessage - -cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory -cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd - where aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } - aux _ = ifd -cleanImageFileDirectory _ ifd = ifd - -instance BinaryParam Endianness ImageFileDirectory where - getP endianness = - ImageFileDirectory <$> getE <*> getE <*> getE <*> getE - <*> pure ExtendedDataNone - where getE :: (BinaryParam Endianness a) => Get a - getE = getP endianness - - putP endianness ifd =do - let putE :: (BinaryParam Endianness a) => a -> Put - putE = putP endianness - putE $ ifdIdentifier ifd - putE $ ifdType ifd - putE $ ifdCount ifd - putE $ ifdOffset ifd - -instance BinaryParam Endianness [ImageFileDirectory] where - getP endianness = do - count <- getP endianness :: Get Word16 - rez <- replicateM (fromIntegral count) $ getP endianness - _ <- getP endianness :: Get Word32 - pure rez - - putP endianness lst = do - let count = fromIntegral $ length lst :: Word16 - putP endianness count - mapM_ (putP endianness) lst - putP endianness (0 :: Word32) - -fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory] -fetchExtended endian = mapM $ \ifd -> do - v <- getP (endian, ifd) - pure $ ifd { ifdExtended = v } - -findIFD :: String -> TiffTag -> [ImageFileDirectory] - -> Get ImageFileDirectory -findIFD errorMessage tag lst = - case [v | v <- lst, ifdIdentifier v == tag] of - [] -> fail errorMessage - (x:_) -> pure x - -findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16)) -findPalette ifds = - case [v | v <- ifds, ifdIdentifier v == TagColorMap] of - (ImageFileDirectory { ifdExtended = ExtendedDataShort vec }:_) -> - pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx - where pixelCount = V.length vec `div` 3 - axx v = vec `V.unsafeIndex` (idx + color * pixelCount) - where (idx, color) = v `divMod` 3 - - _ -> pure Nothing - -findIFDData :: String -> TiffTag -> [ImageFileDirectory] -> Get Word32 -findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst - -findIFDDefaultData :: Word32 -> TiffTag -> [ImageFileDirectory] -> Get Word32 -findIFDDefaultData d tag lst = - case [v | v <- lst, ifdIdentifier v == tag] of - [] -> pure d - (x:_) -> pure $ ifdOffset x - -findIFDExt :: String -> TiffTag -> [ImageFileDirectory] -> Get ExtendedDirectoryData -findIFDExt msg tag lst = do - val <- findIFD msg tag lst - case val of - ImageFileDirectory - { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> - pure . ExtendedDataShort . V.singleton $ fromIntegral ofs - ImageFileDirectory - { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> - pure . ExtendedDataLong . V.singleton $ fromIntegral ofs - ImageFileDirectory { ifdExtended = v } -> pure v - - -findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] - -> Get [Word32] -findIFDExtDefaultData d tag lst = - case [v | v <- lst, ifdIdentifier v == tag] of - [] -> pure d - (ImageFileDirectory { ifdExtended = ExtendedDataNone }:_) -> return d - (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x) - where errorMessage = - "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x) - --- It's temporary, remove once tiff decoding is better --- handled. -{- -instance Show (Image PixelRGB16) where - show _ = "Image PixelRGB16" --} - -data TiffInfo = TiffInfo - { tiffHeader :: TiffHeader - , tiffWidth :: Word32 - , tiffHeight :: Word32 - , tiffColorspace :: TiffColorspace - , tiffSampleCount :: Word32 - , tiffRowPerStrip :: Word32 - , tiffPlaneConfiguration :: TiffPlanarConfiguration - , tiffSampleFormat :: [TiffSampleFormat] - , tiffBitsPerSample :: V.Vector Word32 - , tiffCompression :: TiffCompression - , tiffStripSize :: V.Vector Word32 - , tiffOffsets :: V.Vector Word32 - , tiffPalette :: Maybe (Image PixelRGB16) - , tiffYCbCrSubsampling :: V.Vector Word32 - } - -data TiffColorspace = - TiffMonochromeWhite0 -- ^ 0 - | TiffMonochrome -- ^ 1 - | TiffRGB -- ^ 2 - | TiffPaleted -- ^ 3 - | TiffTransparencyMask -- ^ 4 - | TiffCMYK -- ^ 5 - | TiffYCbCr -- ^ 6 - | TiffCIELab -- ^ 8 - -packPhotometricInterpretation :: TiffColorspace -> Word16 -packPhotometricInterpretation = aux - where - aux TiffMonochromeWhite0 = 0 - aux TiffMonochrome = 1 - aux TiffRGB = 2 - aux TiffPaleted = 3 - aux TiffTransparencyMask = 4 - aux TiffCMYK = 5 - aux TiffYCbCr = 6 - aux TiffCIELab = 8 - -unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace -unpackPhotometricInterpretation = aux - where aux 0 = pure TiffMonochromeWhite0 - aux 1 = pure TiffMonochrome - aux 2 = pure TiffRGB - aux 3 = pure TiffPaleted - aux 4 = pure TiffTransparencyMask - aux 5 = pure TiffCMYK - aux 6 = pure TiffYCbCr - aux 8 = pure TiffCIELab - aux v = fail $ "Unrecognized color space " ++ show v - -unPackCompression :: Word32 -> Get TiffCompression -unPackCompression = aux - where - aux 0 = pure CompressionNone - aux 1 = pure CompressionNone - aux 2 = pure CompressionModifiedRLE - aux 5 = pure CompressionLZW - aux 6 = pure CompressionJPEG - aux 32773 = pure CompressionPackBit - aux v = fail $ "Unknown compression scheme " ++ show v - -packCompression :: TiffCompression -> Word16 -packCompression = aux - where - aux CompressionNone = 1 - aux CompressionModifiedRLE = 2 - aux CompressionLZW = 5 - aux CompressionJPEG = 6 - aux CompressionPackBit = 32773 - -copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) - -> ST s Int -copyByteString str vec stride startWrite (from, count) = inner startWrite fromi - where fromi = fromIntegral from - maxi = fromi + fromIntegral count - - inner writeIdx i | i >= maxi = pure writeIdx - inner writeIdx i = do - let v = str `BU.unsafeIndex` i - (vec `M.unsafeWrite` writeIdx) v - inner (writeIdx + stride) $ i + 1 - -unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int - -> (Word32, Word32) - -> ST s Int -unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex - where fromi = fromIntegral offset - maxi = fromi + fromIntegral size - - replicateByte writeIdx _ 0 = pure writeIdx - replicateByte writeIdx v count = do - (outVec `M.unsafeWrite` writeIdx) v - replicateByte (writeIdx + stride) v $ count - 1 - - loop i writeIdx | i >= maxi = pure writeIdx - loop i writeIdx = choice - {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-} - where v = fromIntegral (str `B.index` i) :: Int8 - - choice - -- data - | 0 <= v = do - copyByteString str outVec stride writeIdx - (fromIntegral $ i + 1, fromIntegral v + 1) - >>= loop (i + 2 + fromIntegral v) - -- run - | -127 <= v = do - {-let nextByte = str `BU.unsafeIndex` (i + 1)-} - let nextByte = str `B.index` (i + 1) - count = negate (fromIntegral v) + 1 :: Int - replicateByte writeIdx nextByte count - >>= loop (i + 2) - - -- noop - | otherwise = loop writeIdx $ i + 1 - -uncompressAt :: TiffCompression - -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) - -> ST s Int -uncompressAt CompressionNone = copyByteString -uncompressAt CompressionPackBit = unpackPackBit -uncompressAt CompressionLZW = \str outVec _stride writeIndex (offset, size) -> do - let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str - runBoolReader $ decodeLzwTiff toDecode outVec writeIndex - return 0 -uncompressAt _ = error "Unhandled compression" - -class Unpackable a where - type StorageType a :: * - - outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a)) - - -- | Final image and size, return offset and vector - allocTempBuffer :: a -> M.STVector s (StorageType a) -> Int - -> ST s (M.STVector s Word8) - - offsetStride :: a -> Int -> Int -> (Int, Int) - - mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker. - -> Endianness - -> M.STVector s Word8 -- ^ Temporary buffer handling decompression. - -> Int -- ^ Line size in pixels - -> Int -- ^ Write index, in bytes - -> Word32 -- ^ size, in bytes - -> Int -- ^ Stride - -> M.STVector s (StorageType a) -- ^ Final buffer - -> ST s () - --- | The Word8 instance is just a passthrough, to avoid --- copying memory twice -instance Unpackable Word8 where - type StorageType Word8 = Word8 - - offsetStride _ i stride = (i, stride) - allocTempBuffer _ buff _ = pure buff - mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure () - outAlloc _ count = M.replicate count 0 -- M.new - -instance Unpackable Word16 where - type StorageType Word16 = Word16 - - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - allocTempBuffer _ _ s = M.new $ s * 2 - mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = - looperLe index 0 - where looperLe _ readIndex | readIndex >= fromIntegral size = pure () - looperLe writeIndex readIndex = do - v1 <- tempVec `M.read` readIndex - v2 <- tempVec `M.read` (readIndex + 1) - let finalValue = - (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1 - (outVec `M.write` writeIndex) finalValue - - looperLe (writeIndex + stride) (readIndex + 2) - mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = - looperBe index 0 - where looperBe _ readIndex | readIndex >= fromIntegral size = pure () - looperBe writeIndex readIndex = do - v1 <- tempVec `M.read` readIndex - v2 <- tempVec `M.read` (readIndex + 1) - let finalValue = - (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2 - (outVec `M.write` writeIndex) finalValue - - looperBe (writeIndex + stride) (readIndex + 2) - -instance Unpackable Word32 where - type StorageType Word32 = Word32 - - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - allocTempBuffer _ _ s = M.new $ s * 4 - mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = - looperLe index 0 - where looperLe _ readIndex | readIndex >= fromIntegral size = pure () - looperLe writeIndex readIndex = do - v1 <- tempVec `M.read` readIndex - v2 <- tempVec `M.read` (readIndex + 1) - v3 <- tempVec `M.read` (readIndex + 2) - v4 <- tempVec `M.read` (readIndex + 3) - let finalValue = - (fromIntegral v4 `unsafeShiftL` 24) .|. - (fromIntegral v3 `unsafeShiftL` 16) .|. - (fromIntegral v2 `unsafeShiftL` 8) .|. - fromIntegral v1 - (outVec `M.write` writeIndex) finalValue - - looperLe (writeIndex + stride) (readIndex + 4) - mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = - looperBe index 0 - where looperBe _ readIndex | readIndex >= fromIntegral size = pure () - looperBe writeIndex readIndex = do - v1 <- tempVec `M.read` readIndex - v2 <- tempVec `M.read` (readIndex + 1) - v3 <- tempVec `M.read` (readIndex + 2) - v4 <- tempVec `M.read` (readIndex + 3) - let finalValue = - (fromIntegral v1 `unsafeShiftL` 24) .|. - (fromIntegral v2 `unsafeShiftL` 16) .|. - (fromIntegral v3 `unsafeShiftL` 8) .|. - fromIntegral v4 - (outVec `M.write` writeIndex) finalValue - - looperBe (writeIndex + stride) (readIndex + 4) - -data Pack4 = Pack4 - -instance Unpackable Pack4 where - type StorageType Pack4 = Word8 - allocTempBuffer _ _ = M.new - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = - inner 0 index pxCount - where pxCount = lineSize `div` stride - - maxWrite = M.length outVec - inner readIdx writeIdx _ - | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () - inner readIdx writeIdx line - | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount - inner readIdx writeIdx line = do - v <- tempVec `M.read` readIdx - let high = (v `unsafeShiftR` 4) .&. 0xF - low = v .&. 0xF - (outVec `M.write` writeIdx) high - when (writeIdx + stride < maxWrite) $ - (outVec `M.write` (writeIdx + stride)) low - - inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2) - -data Pack2 = Pack2 - -instance Unpackable Pack2 where - type StorageType Pack2 = Word8 - allocTempBuffer _ _ = M.new - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = - inner 0 index pxCount - where pxCount = lineSize `div` stride - - maxWrite = M.length outVec - inner readIdx writeIdx _ - | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () - inner readIdx writeIdx line - | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount - inner readIdx writeIdx line = do - v <- tempVec `M.read` readIdx - let v0 = (v `unsafeShiftR` 6) .&. 0x3 - v1 = (v `unsafeShiftR` 4) .&. 0x3 - v2 = (v `unsafeShiftR` 2) .&. 0x3 - v3 = v .&. 0x3 - - (outVec `M.write` writeIdx) v0 - when (writeIdx + 1 * stride < maxWrite) $ - (outVec `M.write` (writeIdx + stride)) v1 - - when (writeIdx + 2 * stride < maxWrite) $ - (outVec `M.write` (writeIdx + stride * 2)) v2 - - when (writeIdx + 3 * stride < maxWrite) $ - (outVec `M.write` (writeIdx + stride * 3)) v3 - - inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4) - -data Pack12 = Pack12 - -instance Unpackable Pack12 where - type StorageType Pack12 = Word16 - allocTempBuffer _ _ = M.new - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = - inner 0 index pxCount - where pxCount = lineSize `div` stride - - maxWrite = M.length outVec - inner readIdx writeIdx _ - | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () - inner readIdx writeIdx line - | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount - inner readIdx writeIdx line = do - v0 <- tempVec `M.read` readIdx - v1 <- if readIdx + 1 < fromIntegral size - then tempVec `M.read` (readIdx + 1) - else pure 0 - v2 <- if readIdx + 2 < fromIntegral size - then tempVec `M.read` (readIdx + 2) - else pure 0 - - let high0 = fromIntegral v0 `unsafeShiftL` 4 - low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF - - p0 = high0 .|. low0 - - high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8 - low1 = fromIntegral v2 - p1 = high1 .|. low1 - - (outVec `M.write` writeIdx) p0 - when (writeIdx + 1 * stride < maxWrite) $ - (outVec `M.write` (writeIdx + stride)) p1 - - inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2) - -data YCbCrSubsampling = YCbCrSubsampling - { ycbcrWidth :: !Int - , ycbcrHeight :: !Int - , ycbcrImageWidth :: !Int - , ycbcrStripHeight :: !Int - } - -instance Unpackable YCbCrSubsampling where - type StorageType YCbCrSubsampling = Word8 - - offsetStride _ _ _ = (0, 1) - outAlloc _ = M.new - allocTempBuffer _ _ = M.new - mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec = - foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1] - , bx <- [0, w .. imgWidth - 1]] - where w = ycbcrWidth subSampling - h = ycbcrHeight subSampling - imgWidth = ycbcrImageWidth subSampling - lineCount = ycbcrStripHeight subSampling - - lumaCount = w * h - blockSize = lumaCount + 2 - - maxOut = M.length outVec - - unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx - unpacker readIdx (bx, by) = do - cb <- tempVec `M.read` (readIdx + lumaCount) - cr <- tempVec `M.read` (readIdx + lumaCount + 1) - - let pixelIndices = - [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]] - - writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex - writer readIndex writeIdx = do - y <- tempVec `M.read` readIndex - (outVec `M.write` writeIdx) y - (outVec `M.write` (writeIdx + 1)) cb - (outVec `M.write` (writeIdx + 2)) cr - return $ readIndex + 1 - - foldM_ writer readIdx pixelIndices - - return $ readIdx + blockSize - -gatherStrips :: ( Unpackable comp - , Pixel pixel - , StorageType comp ~ PixelBaseComponent pixel - ) - => comp -> B.ByteString -> TiffInfo -> Image pixel -gatherStrips comp str nfo = runST $ do - let width = fromIntegral $ tiffWidth nfo - height = fromIntegral $ tiffHeight nfo - sampleCount = if tiffSampleCount nfo /= 0 - then fromIntegral $ tiffSampleCount nfo - else V.length $ tiffBitsPerSample nfo - - rowPerStrip = fromIntegral $ tiffRowPerStrip nfo - endianness = hdrEndianness $ tiffHeader nfo - - stripCount = V.length $ tiffOffsets nfo - compression = tiffCompression nfo - - outVec <- outAlloc comp $ width * height * sampleCount - tempVec <- allocTempBuffer comp outVec - (rowPerStrip * width * sampleCount) - - let mutableImage = MutableImage - { mutableImageWidth = fromIntegral width - , mutableImageHeight = fromIntegral height - , mutableImageData = outVec - } - - case tiffPlaneConfiguration nfo of - PlanarConfigContig -> V.mapM_ unpacker sizes - where unpacker (idx, offset, size) = do - let (writeIdx, tempStride) = offsetStride comp idx 1 - _ <- uncompressAt compression str tempVec tempStride - writeIdx (offset, size) - mergeBackTempBuffer comp endianness tempVec (width * sampleCount) - idx size 1 outVec - - startWriteOffset = - V.generate stripCount(width * rowPerStrip * sampleCount *) - - sizes = V.zip3 startWriteOffset (tiffOffsets nfo) (tiffStripSize nfo) - - PlanarConfigSeparate -> V.mapM_ unpacker sizes - where unpacker (idx, offset, size) = do - let (writeIdx, tempStride) = offsetStride comp idx stride - _ <- uncompressAt compression str tempVec tempStride - writeIdx (offset, size) - mergeBackTempBuffer comp endianness tempVec (width * sampleCount) - idx size stride outVec - - stride = V.length $ tiffOffsets nfo - idxVector = V.enumFromN 0 stride - sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo) - - unsafeFreezeImage mutableImage - -ifdSingleLong :: TiffTag -> Word32 -> Writer [ImageFileDirectory] () -ifdSingleLong tag = ifdMultiLong tag . V.singleton - -ifdSingleShort :: Endianness -> TiffTag -> Word16 - -> Writer [ImageFileDirectory] () -ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral - -ifdMultiLong :: TiffTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () -ifdMultiLong tag v = tell . pure $ ImageFileDirectory - { ifdIdentifier = tag - , ifdType = TypeLong - , ifdCount = fromIntegral $ V.length v - , ifdOffset = offset - , ifdExtended = extended - } - where (offset, extended) - | V.length v > 1 = (0, ExtendedDataLong v) - | otherwise = (V.head v, ExtendedDataNone) - -ifdMultiShort :: Endianness -> TiffTag -> V.Vector Word32 - -> Writer [ImageFileDirectory] () -ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory - { ifdIdentifier = tag - , ifdType = TypeShort - , ifdCount = size - , ifdOffset = offset - , ifdExtended = extended - } - where size = fromIntegral $ V.length v - (offset, extended) - | size > 2 = (0, ExtendedDataShort $ V.map fromIntegral v) - | size == 2 = - let v1 = fromIntegral $ V.head v - v2 = fromIntegral $ v `V.unsafeIndex` 1 - in - case endian of - EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExtendedDataNone) - EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExtendedDataNone) - - | otherwise = case endian of - EndianLittle -> (V.head v, ExtendedDataNone) - EndianBig -> (V.head v `unsafeShiftL` 16, ExtendedDataNone) - --- | All the IFD must be written in order according to the tag --- value of the IFD. To avoid getting to much restriction in the --- serialization code, just sort it. -orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] -orderIfdByTag = sortBy comparer - where comparer a b = compare t1 t2 - where t1 = word16OfTag $ ifdIdentifier a - t2 = word16OfTag $ ifdIdentifier b - --- | Given an official offset and a list of IFD, update the offset information --- of the IFD with extended data. -setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> [ImageFileDirectory] -setupIfdOffsets initialOffset lst = snd $ mapAccumL updater startExtended lst - where ifdElementCount = fromIntegral $ length lst - ifdSize = 12 - ifdCountSize = 2 - nextOffsetSize = 4 - startExtended = initialOffset - + ifdElementCount * ifdSize - + ifdCountSize + nextOffsetSize - - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataAscii b }) = - (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v }) - | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) - , ifd { ifdOffset = ix } ) - updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort v }) - | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) - , ifd { ifdOffset = ix }) - updater ix ifd = (ix, ifd) - -instance BinaryParam B.ByteString TiffInfo where - putP rawData nfo = do - put $ tiffHeader nfo - - let ifdStartOffset = hdrOffset $ tiffHeader nfo - endianness = hdrEndianness $ tiffHeader nfo - - ifdShort = ifdSingleShort endianness - ifdShorts = ifdMultiShort endianness - list = setupIfdOffsets ifdStartOffset . orderIfdByTag . execWriter $ do - ifdSingleLong TagImageWidth $ tiffWidth nfo - ifdSingleLong TagImageLength $ tiffHeight nfo - ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo - ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo - ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo - ifdShort TagPhotometricInterpretation - . packPhotometricInterpretation - $ tiffColorspace nfo - ifdShort TagPlanarConfiguration - . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo - ifdShort TagCompression . packCompression - $ tiffCompression nfo - ifdMultiLong TagStripOffsets $ tiffOffsets nfo - - ifdMultiLong TagStripByteCounts $ tiffStripSize nfo - - let subSampling = tiffYCbCrSubsampling nfo - when (not $ V.null subSampling) $ - ifdShorts TagYCbCrSubsampling subSampling - - putByteString rawData - putP endianness list - mapM_ (\ifd -> putP (endianness, ifd) $ ifdExtended ifd) list - - getP _ = do - hdr <- get - readed <- bytesRead - skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed - let endian = hdrEndianness hdr - - ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian - cleaned <- fetchExtended endian ifd - - let dataFind str tag = findIFDData str tag cleaned - dataDefault def tag = findIFDDefaultData def tag cleaned - extFind str tag = findIFDExt str tag cleaned - extDefault def tag = findIFDExtDefaultData def tag cleaned - - TiffInfo hdr - <$> dataFind "Can't find width" TagImageWidth - <*> dataFind "Can't find height" TagImageLength - <*> (dataFind "Can't find color space" TagPhotometricInterpretation - >>= unpackPhotometricInterpretation) - <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel - <*> dataFind "Can't find row per strip" TagRowPerStrip - <*> (dataDefault 1 TagPlanarConfiguration - >>= planarConfgOfConstant) - <*> (extDefault [1] TagSampleFormat - >>= mapM unpackSampleFormat) - <*> (extFind "Can't find bit per sample" TagBitsPerSample - >>= unLong "Can't find bit depth") - <*> (dataFind "Can't find Compression" TagCompression - >>= unPackCompression) - <*> (extFind "Can't find byte counts" TagStripByteCounts - >>= unLong "Can't find bit per sample") - <*> (extFind "Strip offsets missing" TagStripOffsets - >>= unLong "Can't find strip offsets") - <*> findPalette cleaned - <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) - -unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage --- | while mandatory some images don't put correct --- rowperstrip. So replacing 0 with actual image height. -unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = - unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo } -unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted - , tiffBitsPerSample = lst - , tiffSampleFormat = format - , tiffPalette = Just p - } - | lst == V.singleton 8 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips (0 :: Word8) file nfo - in - pure . ImageRGB16 $ applyPalette gathered - - | lst == V.singleton 4 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack4 file nfo - in - pure . ImageRGB16 $ applyPalette gathered - - | lst == V.singleton 2 && format == [TiffSampleUint] = - let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) - gathered :: Image Pixel8 - gathered = gatherStrips Pack2 file nfo - in - pure . ImageRGB16 $ applyPalette gathered - -unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK - , tiffBitsPerSample = lst - , tiffSampleFormat = format } - | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo - - | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo - -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } - | otherwise = do - img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) - case img of - ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i - ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i - _ -> pure img - -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome - , tiffBitsPerSample = lst - , tiffSampleFormat = format } - | lst == V.singleton 2 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo - | lst == V.singleton 4 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo - | lst == V.singleton 8 && all (TiffSampleUint ==) format = - pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo - | lst == V.singleton 12 && all (TiffSampleUint ==) format = - pure . ImageY16 . pixelMap (16 *) $ gatherStrips Pack12 file nfo - | lst == V.singleton 16 && all (TiffSampleUint ==) format = - pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo - | lst == V.singleton 32 && all (TiffSampleUint ==) format = - pure . ImageY16 $ pixelMap (toWord16) img - where toWord16 v = fromIntegral $ v `unsafeShiftR` 16 - img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 - -unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr - , tiffBitsPerSample = lst - , tiffPlaneConfiguration = PlanarConfigContig - , tiffSampleFormat = format } - | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageYCbCr8 $ gatherStrips cbcrConf file nfo - where defaulting 0 = 2 - defaulting n = n - - w = defaulting $ tiffYCbCrSubsampling nfo V.! 0 - h = defaulting $ tiffYCbCrSubsampling nfo V.! 1 - cbcrConf = YCbCrSubsampling - { ycbcrWidth = fromIntegral w - , ycbcrHeight = fromIntegral h - , ycbcrImageWidth = fromIntegral $ tiffWidth nfo - , ycbcrStripHeight = fromIntegral $ tiffRowPerStrip nfo - } - -unpack file nfo@TiffInfo { tiffColorspace = TiffRGB - , tiffBitsPerSample = lst - , tiffSampleFormat = format } - | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo - | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo - | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo - | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo - | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo - | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = - pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome - , tiffBitsPerSample = lst - , tiffSampleFormat = format } - -- some files are a little bit borked... - | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = - pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo - -unpack _ _ = fail "Failure to unpack TIFF file" - --- | Transform a raw tiff image to an image, without modifying --- the underlying pixel type. --- --- This function can output the following pixel types : --- --- * PixelY8 --- --- * PixelY16 --- --- * PixelRGB8 --- --- * PixelRGB16 --- --- * PixelCMYK8 --- --- * PixelCMYK16 --- -decodeTiff :: B.ByteString -> Either String DynamicImage -decodeTiff file = runGetStrict (getP file) file >>= unpack file - --- | Class defining which pixel types can be serialized in a --- Tiff file. -class (Pixel px) => TiffSaveable px where - colorSpaceOfPixel :: px -> TiffColorspace - - subSamplingInfo :: px -> V.Vector Word32 - subSamplingInfo _ = V.empty - -instance TiffSaveable Pixel8 where - colorSpaceOfPixel _ = TiffMonochrome - -instance TiffSaveable Pixel16 where - colorSpaceOfPixel _ = TiffMonochrome - -instance TiffSaveable PixelCMYK8 where - colorSpaceOfPixel _ = TiffCMYK - -instance TiffSaveable PixelCMYK16 where - colorSpaceOfPixel _ = TiffCMYK - -instance TiffSaveable PixelRGB8 where - colorSpaceOfPixel _ = TiffRGB - -instance TiffSaveable PixelRGB16 where - colorSpaceOfPixel _ = TiffRGB - -instance TiffSaveable PixelRGBA8 where - colorSpaceOfPixel _ = TiffRGB - -instance TiffSaveable PixelRGBA16 where - colorSpaceOfPixel _ = TiffRGB - -instance TiffSaveable PixelYCbCr8 where - colorSpaceOfPixel _ = TiffYCbCr - subSamplingInfo _ = V.fromListN 2 [1, 1] - --- | Transform an image into a Tiff encoded bytestring, reade to be --- written as a file. -encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString -encodeTiff img = runPut $ putP rawPixelData hdr - where intSampleCount = componentCount (undefined :: px) - sampleCount = fromIntegral intSampleCount - - sampleType = (undefined :: PixelBaseComponent px) - pixelData = imageData img - - rawPixelData = toByteString pixelData - width = fromIntegral $ imageWidth img - height = fromIntegral $ imageHeight img - intSampleSize = sizeOf sampleType - sampleSize = fromIntegral intSampleSize - bitPerSample = sampleSize * 8 - imageSize = width * height * sampleCount * sampleSize - headerSize = 8 - - hdr = TiffInfo - { tiffHeader = TiffHeader - { hdrEndianness = EndianLittle - , hdrOffset = headerSize + imageSize - } - , tiffWidth = width - , tiffHeight = height - , tiffColorspace = colorSpaceOfPixel (undefined :: px) - , tiffSampleCount = fromIntegral $ sampleCount - , tiffRowPerStrip = fromIntegral $ imageHeight img - , tiffPlaneConfiguration = PlanarConfigContig - , tiffSampleFormat = [TiffSampleUint] - , tiffBitsPerSample = V.replicate intSampleCount bitPerSample - , tiffCompression = CompressionNone - , tiffStripSize = V.singleton imageSize - , tiffOffsets = V.singleton headerSize - , tiffPalette = Nothing - , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) - } - --- | Helper function to directly write an image as a tiff on disk. -writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO () -writeTiff path img = Lb.writeFile path $ encodeTiff img - diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs deleted file mode 100644 --- a/Codec/Picture/Types.hs +++ /dev/null @@ -1,1727 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} --- | 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 - -- ** Image types - Image( .. ) - , MutableImage( .. ) - , DynamicImage( .. ) - - -- ** Image functions - , freezeImage - , unsafeFreezeImage - - -- ** Pixel types - , Pixel8 - , Pixel16 - , Pixel32 - , PixelF - , PixelYA8( .. ) - , PixelYA16( .. ) - , PixelRGB8( .. ) - , PixelRGB16( .. ) - , PixelRGBF( .. ) - , PixelRGBA8( .. ) - , PixelRGBA16( .. ) - , PixelCMYK8( .. ) - , PixelCMYK16( .. ) - , PixelYCbCr8( .. ) - - -- * Type classes - , ColorConvertible( .. ) - , Pixel(..) - -- $graph - , ColorSpaceConvertible( .. ) - , LumaPlaneExtractable( .. ) - , TransparentPixel( .. ) - - -- * Helper functions - , pixelMap - , pixelFold - , dynamicMap - , dynamicPixelMap - , dropAlphaLayer - , withImage - , generateImage - , generateFoldImage - , gammaCorrection - , toneMapping - - -- * Color plane extraction - , ColorPlane ( ) - - , PlaneRed( .. ) - , PlaneGreen( .. ) - , PlaneBlue( .. ) - , PlaneAlpha( .. ) - , PlaneLuma( .. ) - , PlaneCr( .. ) - , PlaneCb( .. ) - , PlaneCyan( .. ) - , PlaneMagenta( .. ) - , PlaneYellow( .. ) - , PlaneBlack( .. ) - - , extractComponent - , unsafeExtractComponent - ) where - -import Control.Monad( forM_, foldM, liftM, ap ) -import Control.DeepSeq( NFData( .. ) ) -import Control.Monad.ST( runST ) -import Control.Monad.Primitive ( PrimMonad, PrimState ) -import Foreign.Storable ( Storable ) -import Data.Bits( unsafeShiftL, unsafeShiftR ) -import Data.Word( Word8, Word16, Word32 ) -import Data.List( foldl' ) -import Data.Vector.Storable ( (!) ) -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -#include "ConvGraph.hs" - --- | 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. -data Image a = Image - { -- | Width of the image in pixels - imageWidth :: {-# UNPACK #-} !Int - -- | Height of the image in pixels. - , imageHeight :: {-# UNPACK #-} !Int - - -- | The real image, to extract pixels at some position - -- you should use the helpers functions. - , imageData :: V.Vector (PixelBaseComponent a) - } - -{-# INLINE (!!!) #-} -(!!!) :: (Storable e) => V.Vector e -> Int -> e -(!!!) = V.unsafeIndex - --- | Class used to describle plane present in the pixel --- type. If a pixel has a plane description associated, --- you can use the plane name to extract planes independently. -class ColorPlane pixel planeToken where - -- | Retrieve the index of the component in the - -- given pixel type. - toComponentIndex :: pixel -> planeToken -> Int - --- | Define the plane for the red color component -data PlaneRed = PlaneRed - --- | Define the plane for the green color component -data PlaneGreen = PlaneGreen - --- | Define the plane for the blue color component -data PlaneBlue = PlaneBlue - --- | Define the plane for the alpha (transparency) component -data PlaneAlpha = PlaneAlpha - --- | Define the plane for the luma component -data PlaneLuma = PlaneLuma - --- | Define the plane for the Cr component -data PlaneCr = PlaneCr - --- | Define the plane for the Cb component -data PlaneCb = PlaneCb - --- | Define plane for the cyan component of the --- CMYK color space. -data PlaneCyan = PlaneCyan - --- | Define plane for the magenta component of the --- CMYK color space. -data PlaneMagenta = PlaneMagenta - --- | Define plane for the yellow component of the --- CMYK color space. -data PlaneYellow = PlaneYellow - --- | Define plane for the black component of --- the CMYK color space. -data PlaneBlack = PlaneBlack - --- | Extract a color plane from an image given a present plane in the image --- examples : --- --- @ --- extractRedPlane :: Image PixelRGB8-> Image Pixel8 --- extractRedPlane = extractComponent PlaneRed --- @ --- -extractComponent :: forall px plane. ( Pixel px - , Pixel (PixelBaseComponent px) - , PixelBaseComponent (PixelBaseComponent px) - ~ PixelBaseComponent px - , ColorPlane px plane ) - => plane -> Image px -> Image (PixelBaseComponent px) -extractComponent plane = unsafeExtractComponent idx - where idx = toComponentIndex (undefined :: px) plane - --- | Extract an image plane of an image, returning an image which --- can be represented by a gray scale image. --- If you ask a component out of bound, the `error` function will --- be called -unsafeExtractComponent :: forall a - . ( Pixel a - , Pixel (PixelBaseComponent a) - , PixelBaseComponent (PixelBaseComponent a) - ~ PixelBaseComponent a) - => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) - -> Image a -- ^ Source image - -> Image (PixelBaseComponent a) -unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h }) - | comp >= padd = error $ "extractComponent : invalid component index (" - ++ show comp ++ ", max:" ++ show padd ++ ")" - | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } - where plane = stride img 1 padd comp - padd = componentCount (undefined :: a) - --- | 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 PixelRGBA8 PixelRGB8 where - {-# INLINE dropTransparency #-} - dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b - -stride :: (Storable (PixelBaseComponent a)) - => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) -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. -data MutableImage s a = MutableImage - { -- | Width of the image in pixels - mutableImageWidth :: {-# UNPACK #-} !Int - - -- | Height of the image in pixels. - , mutableImageHeight :: {-# UNPACK #-} !Int - - -- | The real image, to extract pixels at some position - -- you should use the helpers functions. - , mutableImageData :: M.STVector s (PixelBaseComponent a) - } - --- | `O(n)` Yield an immutable copy of an image by making a copy of it -freezeImage :: (Storable (PixelBaseComponent a), PrimMonad m) - => MutableImage (PrimState m) a -> m (Image a) -freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d - --- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. --- The mutable image may not be used after this operation. -unsafeFreezeImage :: (Storable (PixelBaseComponent a), PrimMonad m) - => MutableImage (PrimState m) a -> m (Image a) -unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d - -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 = - -- | A greyscale image. - ImageY8 (Image Pixel8) - -- | A greyscale image with 16bit components - | ImageY16 (Image Pixel16) - -- | A greyscale HDR image - | ImageYF (Image PixelF) - -- | An image in greyscale with an alpha channel. - | ImageYA8 (Image PixelYA8) - -- | An image in greyscale with alpha channel on 16 bits. - | ImageYA16 (Image PixelYA16) - -- | An image in true color. - | ImageRGB8 (Image PixelRGB8) - -- | An image in true color with 16bit depth. - | ImageRGB16 (Image PixelRGB16) - -- | An image with HDR pixels - | ImageRGBF (Image PixelRGBF) - -- | An image in true color and an alpha channel. - | ImageRGBA8 (Image PixelRGBA8) - -- | A true color image with alpha on 16 bits. - | ImageRGBA16 (Image PixelRGBA16) - -- | An image in the colorspace used by Jpeg images. - | ImageYCbCr8 (Image PixelYCbCr8) - -- | An image in the colorspace CMYK - | ImageCMYK8 (Image PixelCMYK8) - -- | An image in the colorspace CMYK and 16 bots precision - | ImageCMYK16 (Image PixelCMYK16) - --- | Helper function to help extract information from dynamic --- image. To get the width of an dynamic image, you can use --- the following snippet : --- --- > dynWidth :: DynamicImage -> Int --- > dynWidth img = dynamicMap imageWidth img --- -dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a) - -> DynamicImage -> a -dynamicMap f (ImageY8 i) = f i -dynamicMap f (ImageY16 i) = f i -dynamicMap f (ImageYF i) = f i -dynamicMap f (ImageYA8 i) = f i -dynamicMap f (ImageYA16 i) = f i -dynamicMap f (ImageRGB8 i) = f i -dynamicMap f (ImageRGB16 i) = f i -dynamicMap f (ImageRGBF i) = f i -dynamicMap f (ImageRGBA8 i) = f i -dynamicMap f (ImageRGBA16 i) = f i -dynamicMap f (ImageYCbCr8 i) = f i -dynamicMap f (ImageCMYK8 i) = f i -dynamicMap f (ImageCMYK16 i) = f i - --- | Equivalent of the `pixelMap` function for the dynamic images. --- You can perform pixel colorspace independant operations with this --- function. --- --- For instance, if you wan't to extract a square crop of any image, --- without caring about colorspace, you can use the following snippet. --- --- > dynSquare :: DynamicImage -> DynamicImage --- > dynSquare = dynMap squareImage --- > --- > squareImage :: Pixel a => Image a -> Image a --- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge --- > where edge = min (imageWidth img) (imageHeight img) --- -dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel) - -> DynamicImage -> DynamicImage -dynamicPixelMap f = aux - where - aux (ImageY8 i) = ImageY8 (f i) - aux (ImageY16 i) = ImageY16 (f i) - aux (ImageYF i) = ImageYF (f i) - aux (ImageYA8 i) = ImageYA8 (f i) - aux (ImageYA16 i) = ImageYA16 (f i) - aux (ImageRGB8 i) = ImageRGB8 (f i) - aux (ImageRGB16 i) = ImageRGB16 (f i) - aux (ImageRGBF i) = ImageRGBF (f i) - aux (ImageRGBA8 i) = ImageRGBA8 (f i) - aux (ImageRGBA16 i) = ImageRGBA16 (f i) - aux (ImageYCbCr8 i) = ImageYCbCr8 (f i) - aux (ImageCMYK8 i) = ImageCMYK8 (f i) - aux (ImageCMYK16 i) = ImageCMYK16 (f i) - -instance NFData DynamicImage where - rnf (ImageY8 img) = rnf img - rnf (ImageY16 img) = rnf img - rnf (ImageYF img) = rnf img - rnf (ImageYA8 img) = rnf img - rnf (ImageYA16 img) = rnf img - rnf (ImageRGB8 img) = rnf img - rnf (ImageRGB16 img) = rnf img - rnf (ImageRGBF img) = rnf img - rnf (ImageRGBA8 img) = rnf img - rnf (ImageRGBA16 img) = rnf img - rnf (ImageYCbCr8 img) = rnf img - rnf (ImageCMYK8 img) = rnf img - rnf (ImageCMYK16 img) = rnf img - --- | Simple alias for greyscale value in 8 bits. -type Pixel8 = Word8 - --- | Simple alias for greyscale value in 16 bits. -type Pixel16 = Word16 - --- | Simple alias for greyscale value in 16 bits. -type Pixel32 = Word32 - --- | Floating greyscale value, the 0 to 255 8 bit range maps --- to 0 to 1 in this floating version -type PixelF = Float - --- | Pixel type storing Luminance (Y) and alpha information --- on 8 bits. --- Value are stored in the following order : --- --- * Luminance --- --- * Alpha --- -data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8 -- Luminance - {-# UNPACK #-} !Pixel8 -- Alpha value - deriving (Eq, Show) - --- | Pixel type storing Luminance (Y) and alpha information --- on 16 bits. --- Value are stored in the following order : --- --- * Luminance --- --- * Alpha --- -data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16 -- Luminance - {-# UNPACK #-} !Pixel16 -- Alpha value - deriving (Eq, Show) - --- | Pixel type storing classic pixel on 8 bits --- Value are stored in the following order : --- --- * Red --- --- * Green --- --- * Blue --- -data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red - {-# UNPACK #-} !Pixel8 -- Green - {-# UNPACK #-} !Pixel8 -- Blue - deriving (Eq, Show) - --- | Pixel type storing pixels on 16 bits --- Value are stored in the following order : --- --- * Red --- --- * Green --- --- * Blue --- -data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red - {-# UNPACK #-} !Pixel16 -- Green - {-# UNPACK #-} !Pixel16 -- Blue - deriving (Eq, Show) - --- | Pixel type storing HDR pixel on 32 bits float --- Value are stored in the following order : --- --- * Red --- --- * Green --- --- * Blue --- -data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red - {-# UNPACK #-} !PixelF -- Green - {-# UNPACK #-} !PixelF -- Blue - deriving (Eq, Show) - --- | Pixel storing data in the YCbCr colorspace, --- value are stored in the following order : --- --- * Y (luminance) --- --- * Cr --- --- * Cb --- -data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance - {-# UNPACK #-} !Pixel8 -- Cr red difference - {-# UNPACK #-} !Pixel8 -- Cb blue difference - deriving (Eq, Show) - --- | Pixel storing data in the CMYK colorspace. value --- are stored in the following order : --- --- * Cyan --- --- * Magenta --- --- * Yellow --- --- * Black --- -data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan - {-# UNPACK #-} !Pixel8 -- Magenta - {-# UNPACK #-} !Pixel8 -- Yellow - {-# UNPACK #-} !Pixel8 -- Black - deriving (Eq, Show) - --- | Pixel storing data in the CMYK colorspace. value --- are stored in the following order : --- --- * Cyan --- --- * Magenta --- --- * Yellow --- --- * Black --- -data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan - {-# UNPACK #-} !Pixel16 -- Magenta - {-# UNPACK #-} !Pixel16 -- Yellow - {-# UNPACK #-} !Pixel16 -- Black - deriving (Eq, Show) - - --- | Pixel type storing a classic pixel, with an alpha component. --- Values are stored in the following order --- --- * Red --- --- * Green --- --- * Blue --- --- * Alpha --- -data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red - {-# UNPACK #-} !Pixel8 -- Green - {-# UNPACK #-} !Pixel8 -- Blue - {-# UNPACK #-} !Pixel8 -- Alpha - deriving (Eq, Show) - --- | Pixel type storing a RGB information with an alpha --- channel on 16 bits. --- Values are stored in the following order --- --- * Red --- --- * Green --- --- * Blue --- --- * Alpha --- -data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red - {-# UNPACK #-} !Pixel16 -- Green - {-# UNPACK #-} !Pixel16 -- Blue - {-# UNPACK #-} !Pixel16 -- Alpha - deriving (Eq, Show) - --- | Definition of pixels used in images. Each pixel has a color space, and a representative --- component (Word8 or Float). -class ( Storable (PixelBaseComponent a) - , Num (PixelBaseComponent a), Eq a ) => Pixel a where - -- | Type of the pixel component, "classical" images - -- would have Word8 type as their PixelBaseComponent, - -- HDR image would have Float for instance - type PixelBaseComponent a :: * - - -- | Call the function for every component of the pixels. - -- For example for RGB pixels mixWith is declared like this : - -- - -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = - -- > PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) - -- - mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a) - -> a -> a -> a - - -- | Return the number of component of the pixel - componentCount :: a -> Int - - -- | Apply a function to all color component of a pixel. - colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a - - -- | Calculate the index for the begining of the pixel - pixelBaseIndex :: Image a -> Int -> Int -> Int - pixelBaseIndex (Image { imageWidth = w }) x y = - (x + y * w) * componentCount (undefined :: a) - - -- | Calculate theindex for the begining of the pixel at position x y - mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int - mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = - (x + y * w) * componentCount (undefined :: a) - - -- | Extract a pixel at a given position, (x, y), the origin - -- is assumed to be at the corner top left, positive y to the - -- bottom of the image - pixelAt :: Image a -> Int -> Int -> a - - -- | Same as pixelAt but for mutable images. - readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a - - -- | Write a pixel in a mutable image at position x y - writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m () - - -- | Unsafe version of pixelAt, read a pixel at the given - -- index without bound checking (if possible). - -- The index is expressed in number (PixelBaseComponent a) - unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a - - -- | Unsafe version of readPixel, read a pixel at the given - -- position without bound checking (if possible). The index - -- is expressed in number (PixelBaseComponent a) - unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a - - -- | Unsafe version of writePixel, write a pixel at the - -- given position without bound checking. This can be _really_ unsafe. - -- The index is expressed in number (PixelBaseComponent a) - unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m () - - --- | Implement upcasting for pixel types --- Minimal declaration declaration `promotePixel` --- It is strongly recommanded to overload promoteImage to keep --- performance acceptable -class (Pixel a, Pixel b) => ColorConvertible a b where - -- | Convert a pixel type to another pixel type. This - -- operation should never loss any data. - promotePixel :: a -> b - - -- | Change the underlying pixel type of an image by performing a full copy - -- of it. - promoteImage :: Image a -> Image b - 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 = 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. --- --- for example, to create a small gradient image : --- --- > imageCreator :: String -> Image PixelRGB8 --- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 --- > where pixelRenderer x y = PixelRGB8 x y 128 --- -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 lineGenerator _ y | y >= h = return () - lineGenerator lineIdx y = column lineIdx 0 - where column idx x | x >= w = lineGenerator idx $ y + 1 - column idx x = do - unsafeWritePixel arr idx $ f x y - column (idx + compCount) $ x + 1 - - lineGenerator 0 0 - V.unsafeFreeze arr - --- | Create an image using a monadic initializer function. --- 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. --- --- The function is called for each pixel in the line from left to right (0 to width - 1) --- and for each line (0 to height - 1). -withImage :: forall m pixel. (Pixel pixel, PrimMonad m) - => Int -- ^ Image width - -> Int -- ^ Image height - -> (Int -> Int -> m pixel) -- ^ Generating functions - -> m (Image pixel) -withImage width height pixelGenerator = do - let pixelComponentCount = componentCount (undefined :: pixel) - arr <- M.new (width * height * pixelComponentCount) - let mutImage = MutableImage - { mutableImageWidth = width - , mutableImageHeight = height - , mutableImageData = arr - } - - let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]] - sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx - | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]] - unsafeFreezeImage mutImage - --- | 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. --- --- the acc parameter is a user defined one. --- --- The function is called for each pixel in the line from left to right (0 to width - 1) --- and for each line (0 to height - 1). -generateFoldImage :: forall a acc. (Pixel a) - => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y - -> acc -- ^ Initial state - -> Int -- ^ Width in pixels - -> Int -- ^ Height in pixels - -> (acc, Image a) -generateFoldImage f intialAcc w h = - (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated }) - where compCount = componentCount (undefined :: a) - (finalState, generated) = runST $ do - arr <- M.new (w * h * compCount) - let mutImage = MutableImage { - mutableImageWidth = w, - mutableImageHeight = h, - mutableImageData = arr } - foldResult <- foldM (\acc (x,y) -> do - let (acc', px) = f acc x y - writePixel mutImage x y px - return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] - - frozen <- V.unsafeFreeze arr - return (foldResult, frozen) - --- | Fold over the pixel of an image with a raster scan order : --- from top to bottom, left to right -{-# INLINE pixelFold #-} -pixelFold :: (Pixel pixel) - => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc -pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = - lineFold - where pixelFolder y acc x = f acc x y $ pixelAt img x y - columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] - lineFold = foldl' columnFold initialAccumulator [0 .. h - 1] - --- | `map` equivalent for an image, working at the pixel level. --- Little example : a brightness function for an rgb image --- --- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8 --- > brightnessRGB8 add = pixelMap brightFunction --- > where up v = fromIntegral (fromIntegral v + add) --- > brightFunction (PixelRGB8 r g b) = --- > PixelRGB8 (up r) (up g) (up b) --- -pixelMap :: forall a b. (Pixel a, Pixel b) - => (a -> b) -> Image a -> Image b -{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-} -{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} -{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} -{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} -{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} -{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} -{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} -pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = - Image w h pixels - where sourceComponentCount = componentCount (undefined :: a) - destComponentCount = componentCount (undefined :: b) - - pixels = runST $ do - newArr <- M.new (w * h * destComponentCount) - let lineMapper _ _ y | y >= h = return () - lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 - where colMapper readIdx writeIdx x - | x >= w = lineMapper readIdx writeIdx $ y + 1 - | otherwise = do - unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx - colMapper (readIdx + sourceComponentCount) - (writeIdx + destComponentCount) - (x + 1) - lineMapper 0 0 0 - - -- 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, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where - -- | Compute the luminance part of a pixel - computeLuma :: a -> (PixelBaseComponent a) - - -- | Extract a luma plane out of an image. This - -- method is in the typeclass to help performant - -- implementation. - -- - -- > jpegToGrayScale :: FilePath -> FilePath -> IO () - -- > jpegToGrayScale source dest - extractLumaPlane :: Image a -> Image (PixelBaseComponent a) - extractLumaPlane = pixelMap computeLuma - -instance LumaPlaneExtractable Pixel8 where - {-# INLINE computeLuma #-} - computeLuma = id - extractLumaPlane = id - -instance LumaPlaneExtractable Pixel16 where - {-# INLINE computeLuma #-} - computeLuma = id - extractLumaPlane = id - -instance LumaPlaneExtractable Pixel32 where - {-# INLINE computeLuma #-} - computeLuma = id - extractLumaPlane = id - -instance LumaPlaneExtractable PixelF where - {-# INLINE computeLuma #-} - computeLuma = id - extractLumaPlane = id - -instance LumaPlaneExtractable PixelRGBF where - {-# INLINE computeLuma #-} - computeLuma (PixelRGBF r g b) = - 0.3 * r + 0.59 * g + 0.11 * 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 PixelYCbCr8 where - {-# INLINE computeLuma #-} - computeLuma (PixelYCbCr8 y _ _) = y - extractLumaPlane = extractComponent PlaneLuma - --- | Free promotion for identic pixel types -instance (Pixel a) => ColorConvertible a a where - {-# INLINE promotePixel #-} - promotePixel = id - - {-# INLINE promoteImage #-} - promoteImage = id - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a -(.!!!.) = M.read -- unsafeRead - -{-# INLINE (.<-.) #-} -(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.write -- unsafeWrite - --------------------------------------------------- ----- Pixel8 instances --------------------------------------------------- -instance Pixel Pixel8 where - type PixelBaseComponent Pixel8 = Word8 - - {-# INLINE mixWith #-} - mixWith f = f 0 - - {-# INLINE colorMap #-} - colorMap f = f - - componentCount _ = 1 - pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) - - readPixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.read` mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.write` mutablePixelBaseIndex image x y - - unsafePixelAt = V.unsafeIndex - unsafeReadPixel = M.unsafeRead - unsafeWritePixel = M.unsafeWrite - -instance ColorConvertible Pixel8 PixelYA8 where - {-# INLINE promotePixel #-} - promotePixel c = PixelYA8 c 255 - -instance ColorConvertible Pixel8 PixelF where - {-# INLINE promotePixel #-} - promotePixel c = fromIntegral c / 255.0 - -instance ColorConvertible Pixel8 Pixel16 where - {-# INLINE promotePixel #-} - promotePixel c = fromIntegral c `unsafeShiftL` 8 - -instance ColorConvertible Pixel8 PixelRGB8 where - {-# INLINE promotePixel #-} - promotePixel c = PixelRGB8 c c c - -instance ColorConvertible Pixel8 PixelRGBA8 where - {-# INLINE promotePixel #-} - promotePixel c = PixelRGBA8 c c c 255 - --------------------------------------------------- ----- Pixel16 instances --------------------------------------------------- -instance Pixel Pixel16 where - type PixelBaseComponent Pixel16 = Word16 - - {-# INLINE mixWith #-} - mixWith f = f 0 - - {-# INLINE colorMap #-} - colorMap f = f - - componentCount _ = 1 - pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) - - readPixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.read` mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.write` mutablePixelBaseIndex image x y - - unsafePixelAt = V.unsafeIndex - unsafeReadPixel = M.unsafeRead - unsafeWritePixel = M.unsafeWrite - -instance ColorConvertible Pixel16 PixelYA16 where - {-# INLINE promotePixel #-} - promotePixel c = PixelYA16 c maxBound - -instance ColorConvertible Pixel16 PixelRGB16 where - {-# INLINE promotePixel #-} - promotePixel c = PixelRGB16 c c c - -instance ColorConvertible Pixel16 PixelRGBA16 where - {-# INLINE promotePixel #-} - promotePixel c = PixelRGBA16 c c c maxBound - --------------------------------------------------- ----- Pixel32 instances --------------------------------------------------- -instance Pixel Pixel32 where - type PixelBaseComponent Pixel32 = Word32 - - {-# INLINE mixWith #-} - mixWith f = f 0 - - {-# INLINE colorMap #-} - colorMap f = f - - componentCount _ = 1 - pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) - - readPixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.read` mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.write` mutablePixelBaseIndex image x y - - unsafePixelAt = V.unsafeIndex - unsafeReadPixel = M.unsafeRead - unsafeWritePixel = M.unsafeWrite - --------------------------------------------------- ----- PixelF instances --------------------------------------------------- -instance Pixel PixelF where - type PixelBaseComponent PixelF = Float - - {-# INLINE mixWith #-} - mixWith f = f 0 - - {-# INLINE colorMap #-} - colorMap f = f - componentCount _ = 1 - pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) - - readPixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.read` mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y = - arr `M.write` mutablePixelBaseIndex image x y - - unsafePixelAt = V.unsafeIndex - unsafeReadPixel = M.unsafeRead - unsafeWritePixel = M.unsafeWrite - -instance ColorConvertible PixelF PixelRGBF where - {-# INLINE promotePixel #-} - promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59) (c / 0.11) - --------------------------------------------------- ----- PixelYA8 instances --------------------------------------------------- -instance Pixel PixelYA8 where - type PixelBaseComponent PixelYA8 = Word8 - - {-# INLINE mixWith #-} - mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) = - PixelYA8 (f 0 ya yb) (f 1 aa ab) - - - {-# INLINE colorMap #-} - colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a) - componentCount _ = 2 - pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - yv <- arr .!!!. baseIdx - av <- arr .!!!. (baseIdx + 1) - return $ PixelYA8 yv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) yv - (arr .<-. (baseIdx + 1)) av - - unsafePixelAt v idx = - PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) - unsafeReadPixel vec idx = - PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) - unsafeWritePixel v idx (PixelYA8 y a) = - M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a - -instance ColorConvertible PixelYA8 PixelRGB8 where - {-# INLINE promotePixel #-} - promotePixel (PixelYA8 y _) = PixelRGB8 y y y - -instance ColorConvertible PixelYA8 PixelRGBA8 where - {-# INLINE promotePixel #-} - promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a - -instance ColorPlane PixelYA8 PlaneLuma where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelYA8 PlaneAlpha where - toComponentIndex _ _ = 1 - -instance TransparentPixel PixelYA8 Pixel8 where - {-# INLINE dropTransparency #-} - dropTransparency (PixelYA8 y _) = y - -instance LumaPlaneExtractable PixelYA8 where - {-# INLINE computeLuma #-} - computeLuma (PixelYA8 y _) = y - extractLumaPlane = extractComponent PlaneLuma - --------------------------------------------------- ----- PixelYA16 instances --------------------------------------------------- -instance Pixel PixelYA16 where - type PixelBaseComponent PixelYA16 = Word16 - - {-# INLINE mixWith #-} - mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) = - PixelYA16 (f 0 ya yb) (f 1 aa ab) - - {-# INLINE colorMap #-} - colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a) - componentCount _ = 2 - pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - yv <- arr .!!!. baseIdx - av <- arr .!!!. (baseIdx + 1) - return $ PixelYA16 yv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) yv - (arr .<-. (baseIdx + 1)) av - - unsafePixelAt v idx = - PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) - unsafeReadPixel vec idx = - PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) - unsafeWritePixel v idx (PixelYA16 y a) = - M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a - -instance ColorConvertible PixelYA16 PixelRGBA16 where - {-# INLINE promotePixel #-} - promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a - -instance ColorPlane PixelYA16 PlaneLuma where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelYA16 PlaneAlpha where - toComponentIndex _ _ = 1 - -instance TransparentPixel PixelYA16 Pixel16 where - {-# INLINE dropTransparency #-} - dropTransparency (PixelYA16 y _) = y --------------------------------------------------- ----- PixelRGBF instances --------------------------------------------------- -instance Pixel PixelRGBF where - type PixelBaseComponent PixelRGBF = PixelF - - {-# INLINE mixWith #-} - mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) = - PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) - - {-# INLINE colorMap #-} - colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b) - - componentCount _ = 3 - - pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - return $ PixelRGBF rv gv bv - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - - unsafePixelAt v idx = - PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) - unsafeReadPixel vec idx = - PixelRGBF `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - unsafeWritePixel v idx (PixelRGBF r g b) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - -instance ColorPlane PixelRGBF PlaneRed where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelRGBF PlaneGreen where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelRGBF PlaneBlue where - toComponentIndex _ _ = 2 - --------------------------------------------------- ----- PixelRGB16 instances --------------------------------------------------- -instance Pixel PixelRGB16 where - type PixelBaseComponent PixelRGB16 = Pixel16 - - {-# INLINE mixWith #-} - mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) = - PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) - - {-# INLINE colorMap #-} - colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) - - componentCount _ = 3 - - pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - return $ PixelRGB16 rv gv bv - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - - unsafePixelAt v idx = - PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) - unsafeReadPixel vec idx = - PixelRGB16 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - unsafeWritePixel v idx (PixelRGB16 r g b) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - -instance ColorPlane PixelRGB16 PlaneRed where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelRGB16 PlaneGreen where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelRGB16 PlaneBlue where - toComponentIndex _ _ = 2 - -instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where - {-# INLINE convertPixel #-} - convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b) - -instance ColorConvertible PixelRGB16 PixelRGBA16 where - {-# INLINE promotePixel #-} - promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound - -instance LumaPlaneExtractable PixelRGB16 where - {-# INLINE computeLuma #-} - computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b --------------------------------------------------- ----- PixelRGB8 instances --------------------------------------------------- -instance Pixel PixelRGB8 where - type PixelBaseComponent PixelRGB8 = Word8 - - {-# INLINE mixWith #-} - mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = - PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) - - {-# INLINE colorMap #-} - colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b) - - componentCount _ = 3 - - pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - return $ PixelRGB8 rv gv bv - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - - unsafePixelAt v idx = - PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) - unsafeReadPixel vec idx = - PixelRGB8 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - unsafeWritePixel v idx (PixelRGB8 r g b) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - -instance ColorConvertible PixelRGB8 PixelRGBA8 where - {-# INLINE promotePixel #-} - promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound - -instance ColorConvertible PixelRGB8 PixelRGBF where - {-# INLINE promotePixel #-} - promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) - where toF v = fromIntegral v / 255.0 - -instance ColorPlane PixelRGB8 PlaneRed where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelRGB8 PlaneGreen where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelRGB8 PlaneBlue where - toComponentIndex _ _ = 2 - -instance LumaPlaneExtractable PixelRGB8 where - {-# INLINE computeLuma #-} - computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + - 0.59 * toRational g + - 0.11 * toRational b - --------------------------------------------------- ----- PixelRGBA8 instances --------------------------------------------------- -instance Pixel PixelRGBA8 where - type PixelBaseComponent PixelRGBA8 = Word8 - - {-# INLINE mixWith #-} - mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = - PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) - - {-# INLINE colorMap #-} - colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) - - componentCount _ = 4 - - pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - (arr ! (baseIdx + 3)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - av <- arr .!!!. (baseIdx + 3) - return $ PixelRGBA8 rv gv bv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - (arr .<-. (baseIdx + 3)) av - - unsafePixelAt v idx = - PixelRGBA8 (V.unsafeIndex v idx) - (V.unsafeIndex v $ idx + 1) - (V.unsafeIndex v $ idx + 2) - (V.unsafeIndex v $ idx + 3) - unsafeReadPixel vec idx = - PixelRGBA8 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - `ap` M.unsafeRead vec (idx + 3) - unsafeWritePixel v idx (PixelRGBA8 r g b a) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - >> M.unsafeWrite v (idx + 3) a - -instance ColorPlane PixelRGBA8 PlaneRed where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelRGBA8 PlaneGreen where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelRGBA8 PlaneBlue where - toComponentIndex _ _ = 2 - -instance ColorPlane PixelRGBA8 PlaneAlpha where - toComponentIndex _ _ = 3 - --------------------------------------------------- ----- PixelRGBA16 instances --------------------------------------------------- -instance Pixel PixelRGBA16 where - type PixelBaseComponent PixelRGBA16 = Pixel16 - - {-# INLINE mixWith #-} - mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = - PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) - - {-# INLINE colorMap #-} - colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a) - - componentCount _ = 4 - - pixelAt image@(Image { imageData = arr }) x y = - PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - av <- arr .!!!. (baseIdx + 3) - return $ PixelRGBA16 rv gv bv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - (arr .<-. (baseIdx + 3)) av - - unsafePixelAt v idx = - PixelRGBA16 (V.unsafeIndex v idx) - (V.unsafeIndex v $ idx + 1) - (V.unsafeIndex v $ idx + 2) - (V.unsafeIndex v $ idx + 3) - unsafeReadPixel vec idx = - PixelRGBA16 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - `ap` M.unsafeRead vec (idx + 3) - unsafeWritePixel v idx (PixelRGBA16 r g b a) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - >> M.unsafeWrite v (idx + 3) a - - -instance TransparentPixel PixelRGBA16 PixelRGB16 where - {-# INLINE dropTransparency #-} - dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b - -instance ColorPlane PixelRGBA16 PlaneRed where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelRGBA16 PlaneGreen where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelRGBA16 PlaneBlue where - toComponentIndex _ _ = 2 - -instance ColorPlane PixelRGBA16 PlaneAlpha where - toComponentIndex _ _ = 3 - --------------------------------------------------- ----- PixelYCbCr8 instances --------------------------------------------------- -instance Pixel PixelYCbCr8 where - type PixelBaseComponent PixelYCbCr8 = Word8 - - {-# INLINE mixWith #-} - mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) = - PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) - - {-# INLINE colorMap #-} - colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr) - componentCount _ = 3 - pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - yv <- arr .!!!. baseIdx - cbv <- arr .!!!. (baseIdx + 1) - crv <- arr .!!!. (baseIdx + 2) - return $ PixelYCbCr8 yv cbv crv - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) yv - (arr .<-. (baseIdx + 1)) cbv - (arr .<-. (baseIdx + 2)) crv - - unsafePixelAt v idx = - PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) - unsafeReadPixel vec idx = - PixelYCbCr8 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - unsafeWritePixel v idx (PixelYCbCr8 y cb cr) = - M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb - >> M.unsafeWrite v (idx + 2) cr - -instance (Pixel a) => ColorSpaceConvertible a a where - convertPixel = id - convertImage = id - -scaleBits, oneHalf :: Int -scaleBits = 16 -oneHalf = 1 `unsafeShiftL` (scaleBits - 1) - -fix :: Float -> Int -fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5 - - -rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int -rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ] -gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ] -bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ] -rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ] -gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ] -bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ] -gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ] -bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ] - - -instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where - {-# INLINE convertPixel #-} - convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr) - where ri = fromIntegral r - gi = fromIntegral g - bi = fromIntegral b - - y = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits - cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits - cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits - - convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData - where maxi = w * h - - rY = fix 0.29900 - gY = fix 0.58700 - bY = fix 0.11400 - rCb = (- fix 0.16874) - gCb = (- fix 0.33126) - bCb = fix 0.5 - gCr = (- fix 0.41869) - bCr = (- fix 0.08131) - - newData = runST $ do - block <- M.new $ maxi * 3 - let traductor _ idx | idx >= maxi = return block - traductor readIdx idx = do - let ri = fromIntegral $ d `V.unsafeIndex` readIdx - gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) - bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) - - y = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits - cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits - cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits - - (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y - (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb - (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr - traductor (readIdx + 3) (idx + 1) - - traductor 0 0 >>= V.freeze - -crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int -crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] -cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] -crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]] -cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]] - -instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where - {-# INLINE convertPixel #-} - convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) - where clampWord8 = fromIntegral . max 0 . min 255 - yi = fromIntegral y - cbi = fromIntegral cb - cri = fromIntegral cr - - r = yi + crRTab `V.unsafeIndex` cri - g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits - b = yi + cbBTab `V.unsafeIndex` cbi - - convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData - where maxi = w * h - clampWord8 v | v < 0 = 0 - | v > 255 = 255 - | otherwise = fromIntegral v - - newData = runST $ do - block <- M.new $ maxi * 3 - let traductor _ idx | idx >= maxi = return block - traductor readIdx idx = do - let yi = fromIntegral $ d `V.unsafeIndex` readIdx - cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) - cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) - - r = yi + crRTab `V.unsafeIndex` cri - g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits - b = yi + cbBTab `V.unsafeIndex` cbi - - (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r - (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g - (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b - traductor (readIdx + 3) (idx + 1) - - traductor 0 0 >>= V.freeze - -instance ColorPlane PixelYCbCr8 PlaneLuma where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelYCbCr8 PlaneCb where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelYCbCr8 PlaneCr where - toComponentIndex _ _ = 2 - --------------------------------------------------- ----- PixelCMYK8 instances --------------------------------------------------- -instance Pixel PixelCMYK8 where - type PixelBaseComponent PixelCMYK8 = Word8 - - {-# INLINE mixWith #-} - mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) = - PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) - - {-# INLINE colorMap #-} - colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k) - - componentCount _ = 4 - - pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - (arr ! (baseIdx + 3)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - av <- arr .!!!. (baseIdx + 3) - return $ PixelCMYK8 rv gv bv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - (arr .<-. (baseIdx + 3)) av - - unsafePixelAt v idx = - PixelCMYK8 (V.unsafeIndex v idx) - (V.unsafeIndex v $ idx + 1) - (V.unsafeIndex v $ idx + 2) - (V.unsafeIndex v $ idx + 3) - unsafeReadPixel vec idx = - PixelCMYK8 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - `ap` M.unsafeRead vec (idx + 3) - unsafeWritePixel v idx (PixelCMYK8 r g b a) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - >> M.unsafeWrite v (idx + 3) a - -instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where - convertPixel (PixelCMYK8 c m y k) = - PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) - where - clampWord8 = fromIntegral . (`unsafeShiftR` 8) - ik :: Int - ik = 255 - fromIntegral k - - r = (255 - fromIntegral c) * ik - g = (255 - fromIntegral m) * ik - b = (255 - fromIntegral y) * ik - - -{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b) - -> (Word8, Word8, Word8) -> b #-} -{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b) - -> (Word16, Word16, Word16) -> b #-} -integralRGBToCMYK :: (Bounded a, Integral a) - => (a -> a -> a -> a -> b) -- ^ Pixel building function - -> (a, a, a) -- ^ RGB sample - -> b -- ^ Resulting sample -integralRGBToCMYK build (r, g, b) = - build (clamp c) (clamp m) (clamp y) (fromIntegral kInt) - where maxi = maxBound - - ir = fromIntegral $ maxi - r :: Int - ig = fromIntegral $ maxi - g - ib = fromIntegral $ maxi - b - - kInt = minimum [ir, ig, ib] - ik = fromIntegral maxi - kInt - - c = (ir - kInt) `div` ik - m = (ig - kInt) `div` ik - y = (ib - kInt) `div` ik - - clamp = fromIntegral . (max 0) - -instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where - convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) - -instance ColorPlane PixelCMYK8 PlaneCyan where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelCMYK8 PlaneMagenta where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelCMYK8 PlaneYellow where - toComponentIndex _ _ = 2 - -instance ColorPlane PixelCMYK8 PlaneBlack where - toComponentIndex _ _ = 3 - --------------------------------------------------- ----- PixelCMYK16 instances --------------------------------------------------- -instance Pixel PixelCMYK16 where - type PixelBaseComponent PixelCMYK16 = Word16 - - {-# INLINE mixWith #-} - mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) = - PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) - - {-# INLINE colorMap #-} - colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k) - - componentCount _ = 4 - - pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0)) - (arr ! (baseIdx + 1)) - (arr ! (baseIdx + 2)) - (arr ! (baseIdx + 3)) - where baseIdx = pixelBaseIndex image x y - - readPixel image@(MutableImage { mutableImageData = arr }) x y = do - rv <- arr .!!!. baseIdx - gv <- arr .!!!. (baseIdx + 1) - bv <- arr .!!!. (baseIdx + 2) - av <- arr .!!!. (baseIdx + 3) - return $ PixelCMYK16 rv gv bv av - where baseIdx = mutablePixelBaseIndex image x y - - writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do - let baseIdx = mutablePixelBaseIndex image x y - (arr .<-. (baseIdx + 0)) rv - (arr .<-. (baseIdx + 1)) gv - (arr .<-. (baseIdx + 2)) bv - (arr .<-. (baseIdx + 3)) av - - unsafePixelAt v idx = - PixelCMYK16 (V.unsafeIndex v idx) - (V.unsafeIndex v $ idx + 1) - (V.unsafeIndex v $ idx + 2) - (V.unsafeIndex v $ idx + 3) - unsafeReadPixel vec idx = - PixelCMYK16 `liftM` M.unsafeRead vec idx - `ap` M.unsafeRead vec (idx + 1) - `ap` M.unsafeRead vec (idx + 2) - `ap` M.unsafeRead vec (idx + 3) - unsafeWritePixel v idx (PixelCMYK16 r g b a) = - M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g - >> M.unsafeWrite v (idx + 2) b - >> M.unsafeWrite v (idx + 3) a - -instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where - convertPixel (PixelCMYK16 c m y k) = - PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b) - where - clampWord16 = fromIntegral . (`unsafeShiftR` 16) - ik :: Int - ik = 65535 - fromIntegral k - - r = (65535 - fromIntegral c) * ik - g = (65535 - fromIntegral m) * ik - b = (65535 - fromIntegral y) * ik - -instance ColorPlane PixelCMYK16 PlaneCyan where - toComponentIndex _ _ = 0 - -instance ColorPlane PixelCMYK16 PlaneMagenta where - toComponentIndex _ _ = 1 - -instance ColorPlane PixelCMYK16 PlaneYellow where - toComponentIndex _ _ = 2 - -instance ColorPlane PixelCMYK16 PlaneBlack where - toComponentIndex _ _ = 3 - --- | Perform a gamma correction for an image with HDR pixels. -gammaCorrection :: PixelF -- ^ Gamma value, should be between 0.5 and 3.0 - -> Image PixelRGBF -- ^ Image to treat. - -> Image PixelRGBF -gammaCorrection gammaVal = pixelMap gammaCorrector - where gammaExponent = 1.0 / gammaVal - fixVal v = v ** gammaExponent - gammaCorrector (PixelRGBF r g b) = - PixelRGBF (fixVal r) (fixVal g) (fixVal b) - --- | Perform a tone mapping operation on an High dynamic range image. -toneMapping :: PixelF -- ^ Exposure parameter - -> Image PixelRGBF -- ^ Image to treat. - -> Image PixelRGBF -toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData - where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0); - maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img - scaledData = V.map (* coeff) $ imageData img - diff --git a/Codec/Picture/VectorByteConversion.hs b/Codec/Picture/VectorByteConversion.hs deleted file mode 100644 --- a/Codec/Picture/VectorByteConversion.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module Codec.Picture.VectorByteConversion( blitVector, toByteString ) where - -import Data.Word( Word8 ) -import Data.Vector.Storable( Vector, unsafeToForeignPtr ) -import Foreign.ForeignPtr.Safe( castForeignPtr ) -import Foreign.Storable( Storable, sizeOf ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as S - -blitVector :: Vector Word8 -> Int -> Int -> B.ByteString -blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize - where (ptr, offset, _length) = unsafeToForeignPtr vec - -toByteString :: forall a. (Storable a) => Vector a -> B.ByteString -toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) - where (ptr, offset, len) = unsafeToForeignPtr vec - size = sizeOf (undefined :: a) - diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,10 +1,10 @@ Name: JuicyPixels -Version: 3.1.2 +Version: 3.1.3 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) Description: <> . - This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and read Gif images. + This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and Gif images. homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 @@ -26,13 +26,14 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1.2 + Tag: v3.1.3 Flag Mmap Description: Enable the file loading via mmap (memory map) Default: False Library + hs-source-dirs: src Default-Language: Haskell2010 Exposed-modules: Codec.Picture, Codec.Picture.Bitmap, @@ -42,7 +43,8 @@ Codec.Picture.HDR, Codec.Picture.Tiff, Codec.Picture.Saving, - Codec.Picture.Types + Codec.Picture.Types, + Codec.Picture.ColorQuant Ghc-options: -O3 -Wall Build-depends: base >= 4 && < 5, @@ -53,7 +55,8 @@ transformers >= 0.2.2 && < 0.4, vector >= 0.9 && < 0.11, primitive >= 0.5 && < 0.6, - deepseq >= 1.1 && < 1.4 + deepseq >= 1.1 && < 1.4, + containers >= 0.5 && < 0.6 if flag(Mmap) Build-depends: mmap @@ -67,12 +70,13 @@ Codec.Picture.Jpg.Common, Codec.Picture.Jpg.Progressive, Codec.Picture.Gif.LZW, + Codec.Picture.Gif.LZWEncoding, Codec.Picture.Png.Export, Codec.Picture.Png.Type, Codec.Picture.BitWriter, Codec.Picture.InternalHelper, Codec.Picture.VectorByteConversion - Install-Includes: Codec/Picture/ConvGraph.hs - Include-Dirs: Codec/Picture + Install-Includes: src/Codec/Picture/ConvGraph.hs + Include-Dirs: src/Codec/Picture diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,11 @@ -*-change-log-*- +v3.1.3 + * Adding palette creation (color Quantization) by Jeffrey Rosenbluth. + * Adding support for Gif writing + * Adding support for Gif animation writing + * Fixing some progressive Jpeg decoding problems (#39) + v3.1.2 December 2013 * Adding support for progressive jpeg. * Adding support for plane separated MCU jpeg. diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture.hs @@ -0,0 +1,304 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} +-- | Main module for image import/export into various image formats. +-- +-- To use the library without thinking about it, look after 'decodeImage' and +-- 'readImage'. +-- +-- Generally, the read* functions read the images from a file and try to decode +-- it, and the decode* functions try to decode a bytestring. +-- +-- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage' +-- functions +module Codec.Picture ( + -- * Generic functions + readImage + , decodeImage + , pixelMap + , generateImage + , generateFoldImage + , withImage + + -- * Generic image writing + , saveBmpImage + , saveJpgImage + , saveGifImage + , savePngImage + , saveTiffImage + , saveRadianceImage + + -- * Specific image format functions + -- ** Bitmap handling + , BmpEncodable + , writeBitmap + , encodeBitmap + , readBitmap + , decodeBitmap + , encodeDynamicBitmap + , writeDynamicBitmap + + -- ** Gif handling + , readGif + , readGifImages + , decodeGif + , decodeGifImages + + , encodeGifImage + , writeGifImage + , encodeGifImageWithPalette + , writeGifImageWithPalette + , encodeColorReducedGifImage + , writeColorReducedGifImage + , encodeGifImages + , writeGifImages + + -- *** Gif animation + , GifDelay + , GifLooping( .. ) + , encodeGifAnimation + , writeGifAnimation + + -- ** Jpeg handling + , readJpeg + , decodeJpeg + , encodeJpeg + , encodeJpegAtQuality + + -- ** Png handling + , PngSavable( .. ) + , readPng + , decodePng + , writePng + , encodePalettedPng + , encodeDynamicPng + , writeDynamicPng + + -- ** Tiff handling + , readTiff + , TiffSaveable + , decodeTiff + , encodeTiff + , writeTiff + + -- ** HDR (Radiance/RGBE) handling + , readHDR + , decodeHDR + , encodeHDR + , writeHDR + + -- ** Color Quantization + , PaletteCreationMethod(..) + , PaletteOptions(..) + , palettize + + -- * Image types and pixel types + -- ** Image + , Image( .. ) + , DynamicImage( .. ) + , Palette + -- ** Pixels + , Pixel( .. ) + -- $graph + , Pixel8 + , Pixel16 + , PixelF + + , PixelYA8( .. ) + , PixelYA16( .. ) + , PixelRGB8( .. ) + , PixelRGB16( .. ) + , PixelRGBF( .. ) + , PixelRGBA8( .. ) + , PixelRGBA16( .. ) + , PixelYCbCr8( .. ) + , PixelCMYK8( .. ) + , PixelCMYK16( .. ) + + -- * Foreign unsafe import + , imageFromUnsafePtr + ) where + +import Control.Applicative( (<$>) ) +import Control.DeepSeq( NFData, deepseq ) +import qualified Control.Exception as Exc ( 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 + , encodePalettedPng + , writeDynamicPng + ) + +import Codec.Picture.Gif( GifDelay + , GifLooping( .. ) + , decodeGif + , decodeGifImages + , encodeGifImage + , encodeGifImageWithPalette + , encodeGifImages + + , writeGifImage + , writeGifImageWithPalette + , writeGifImages + ) + +import Codec.Picture.HDR( decodeHDR + , encodeHDR + , writeHDR + ) +import Codec.Picture.Tiff( decodeTiff + , TiffSaveable + , encodeTiff + , writeTiff ) +import Codec.Picture.Saving +import Codec.Picture.Types +import Codec.Picture.ColorQuant +import Codec.Picture.VectorByteConversion( imageFromUnsafePtr ) +-- import System.IO ( withFile, IOMode(ReadMode) ) +#ifdef WITH_MMAP_BYTESTRING +import System.IO.MMap ( mmapFileByteString ) +#endif + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +#include "ConvGraph.hs" + +-- | Return the first Right thing, accumulating error +eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b +eitherLoad v = inner "" + where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc + inner errAcc ((hdr, f) : rest) = case f v of + Left err -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest + Right rez -> Right rez + +-- | Encode a full color image to a gif by applying a color quantization +-- algorithm on it. +encodeColorReducedGifImage :: Image PixelRGB8 -> Either String L.ByteString +encodeColorReducedGifImage img = encodeGifImageWithPalette indexed pal + where (indexed, pal) = palettize defaultPaletteOptions img + +-- | Write a full color image to a gif by applying a color quantization +-- algorithm on it. +writeColorReducedGifImage :: FilePath -> Image PixelRGB8 -> Either String (IO ()) +writeColorReducedGifImage path img = + L.writeFile path <$> encodeColorReducedGifImage img + + +-- | Helper function to create a gif animation. +-- All the images of the animation are separated +-- by the same delay. +encodeGifAnimation :: GifDelay -> GifLooping + -> [Image PixelRGB8] -> Either String (L.ByteString) +encodeGifAnimation delay looping lst = + encodeGifImages looping + [(pal, delay, img) + | (img, pal) <- palettize defaultPaletteOptions <$> lst] + +-- | Helper function to write a gif animtion on disk. +-- See encodeGifAnimation +writeGifAnimation :: FilePath -> GifDelay -> GifLooping + -> [Image PixelRGB8] -> Either String (IO ()) +writeGifAnimation path delay looping img = + L.writeFile path <$> encodeGifAnimation delay looping img + +withImageDecoder :: (NFData a) + => (B.ByteString -> Either String a) -> FilePath + -> IO (Either String a) +withImageDecoder decoder path = Exc.catch doit + (\e -> return . Left $ show (e :: Exc.IOException)) + where doit = force . decoder <$> get +#ifdef WITH_MMAP_BYTESTRING + get = mmapFileByteString path Nothing +#else + get = B.readFile path +#endif + -- 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 = 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 +-- to decode in each known format and if one decoding succeed will return +-- the decoded image in it's own colorspace +decodeImage :: B.ByteString -> Either String DynamicImage +decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) + ,("PNG", decodePng) + ,("Bitmap", decodeBitmap) + ,("GIF", decodeGif) + ,("HDR", decodeHDR) + ,("Tiff", decodeTiff) + ] + +-- | Helper function trying to load a png file from a file on disk. +readPng :: FilePath -> IO (Either String DynamicImage) +readPng = withImageDecoder decodePng + +-- | Helper function trying to load a gif file from a file on disk. +readGif :: FilePath -> IO (Either String DynamicImage) +readGif = withImageDecoder decodeGif + +-- | Helper function trying to load tiff file from a file on disk. +readTiff :: FilePath -> IO (Either String DynamicImage) +readTiff = withImageDecoder decodeTiff + +-- | Helper function trying to load all the images of an animated +-- gif file. +readGifImages :: FilePath -> IO (Either String [Image PixelRGB8]) +readGifImages = withImageDecoder decodeGifImages + +-- | 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 + +-- | Try to load a .pic file. The colorspace can only be +-- RGB with floating point precision. +readHDR :: FilePath -> IO (Either String DynamicImage) +readHDR = withImageDecoder decodeHDR + +-- | Save an image to a '.jpg' file, will do everything it can to save an image. +saveJpgImage :: Int -> FilePath -> DynamicImage -> IO () +saveJpgImage quality path img = L.writeFile path $ imageToJpg quality img + +-- | Save an image to a '.gif' file, will do everything it can to save it. +saveGifImage :: FilePath -> DynamicImage -> Either String (IO ()) +saveGifImage path img = L.writeFile path <$> imageToGif img + +-- | Save an image to a '.tiff' file, will do everything it can to save an image. +saveTiffImage :: FilePath -> DynamicImage -> IO () +saveTiffImage path img = L.writeFile path $ imageToTiff img + +-- | Save an image to a '.hdr' file, will do everything it can to save an image. +saveRadianceImage :: FilePath -> DynamicImage -> IO () +saveRadianceImage path = L.writeFile path . imageToRadiance + +-- | Save an image to a '.png' file, will do everything it can to save an image. +-- For example, a simple transcoder to png +-- +-- > transcodeToPng :: FilePath -> FilePath -> IO () +-- > transcodeToPng pathIn pathOut = do +-- > eitherImg <- readImage pathIn +-- > case eitherImg of +-- > Left _ -> return () +-- > Right img -> savePngImage pathOut img +-- +savePngImage :: FilePath -> DynamicImage -> IO () +savePngImage path img = L.writeFile path $ imageToPng img + +-- | Save an image to a '.bmp' file, will do everything it can to save an image. +saveBmpImage :: FilePath -> DynamicImage -> IO () +saveBmpImage path img = L.writeFile path $ imageToBitmap img + diff --git a/src/Codec/Picture/BitWriter.hs b/src/Codec/Picture/BitWriter.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/BitWriter.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE Rank2Types #-} +-- | This module implement helper functions to read & write data +-- at bits level. +module Codec.Picture.BitWriter( BoolReader + , emptyBoolState + , BoolState + , byteAlignJpg + , getNextBitsLSBFirst + , getNextBitsMSBFirst + , getNextBitJpg + , setDecodedString + , setDecodedStringJpg + , runBoolReader + + , BoolWriteStateRef + , newWriteStateRef + , finalizeBoolWriter + , writeBits' + , writeBitsGif + + , initBoolState + , initBoolStateJpg + , execBoolReader + , runBoolReaderWith + ) where + +import Data.STRef +import Control.Applicative( (<$>), (<*>) ) +import Control.Monad( when ) +import Control.Monad.ST( ST ) +import qualified Control.Monad.Trans.State.Strict as S +import Data.Word( Word8, Word32 ) +import Data.Bits( Bits, (.&.), (.|.), unsafeShiftR, unsafeShiftL ) + +import Codec.Picture.VectorByteConversion( blitVector ) +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.Vector.Storable as VS +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +-------------------------------------------------- +---- Reader +-------------------------------------------------- +-- | Current bit index, current value, string +data BoolState = BoolState {-# UNPACK #-} !Int + {-# UNPACK #-} !Word8 + !B.ByteString + +emptyBoolState :: BoolState +emptyBoolState = BoolState (-1) 0 B.empty + +-- | Type used to read bits +type BoolReader s a = S.StateT BoolState (ST s) a + +runBoolReader :: BoolReader s a -> ST s a +runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty + +runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState) +runBoolReaderWith st action = S.runStateT action st + +execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState +execBoolReader st reader = S.execStateT reader st + +initBoolState :: B.ByteString -> BoolState +initBoolState str = case B.uncons str of + Nothing -> BoolState 0 0 B.empty + Just (v, rest) -> BoolState 0 v rest + +initBoolStateJpg :: B.ByteString -> BoolState +initBoolStateJpg str = + case B.uncons str of + Nothing -> BoolState 0 0 B.empty + Just (0xFF, rest) -> case B.uncons rest of + Nothing -> BoolState maxBound 0 B.empty + Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker + Just (_ , afterMarker) -> initBoolStateJpg afterMarker + Just (v, rest) -> BoolState 7 v rest + +-- | Bitify a list of things to decode. +setDecodedString :: B.ByteString -> BoolReader s () +setDecodedString str = case B.uncons str of + Nothing -> S.put $ BoolState 0 0 B.empty + Just (v, rest) -> S.put $ BoolState 0 v rest + +-- | Drop all bit until the bit of indice 0, usefull to parse restart +-- marker, as they are byte aligned, but Huffman might not. +byteAlignJpg :: BoolReader s () +byteAlignJpg = do + BoolState idx _ chain <- S.get + when (idx /= 7) (setDecodedStringJpg chain) + +{-# INLINE getNextBitJpg #-} +getNextBitJpg :: BoolReader s Bool +getNextBitJpg = do + BoolState idx v chain <- S.get + let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 + if idx == 0 + then setDecodedStringJpg chain + else S.put $ BoolState (idx - 1) v chain + return val + +{-# INLINE getNextBitMSB #-} +getNextBitMSB :: BoolReader s Bool +getNextBitMSB = do + BoolState idx v chain <- S.get + let val = (v .&. (1 `unsafeShiftL` (7 - idx))) /= 0 + if idx == 7 + then setDecodedString chain + else S.put $ BoolState (idx + 1) v chain + return val + +{-# INLINE getNextBitsMSBFirst #-} +getNextBitsMSBFirst :: Int -> BoolReader s Word32 +getNextBitsMSBFirst count = aux 0 count + where aux acc 0 = return acc + aux acc n = do + bit <- getNextBitMSB + let nextVal | bit = (acc `unsafeShiftL` 1) .|. 1 + | otherwise = acc `unsafeShiftL` 1 + aux nextVal (n - 1) + +{-# INLINE getNextBitsLSBFirst #-} +getNextBitsLSBFirst :: Int -> BoolReader s Word32 +getNextBitsLSBFirst count = aux 0 count + where aux acc 0 = return acc + aux acc n = do + bit <- getNextBit + let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n)) + | otherwise = acc + aux nextVal (n - 1) + +{-# INLINE getNextBit #-} +getNextBit :: BoolReader s Bool +getNextBit = do + BoolState idx v chain <- S.get + let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 + if idx == 7 + then setDecodedString chain + else S.put $ BoolState (idx + 1) v chain + return val + +-- | Bitify a list of things to decode. Handle Jpeg escape +-- code (0xFF 0x00), thus should be only used in JPEG decoding. +setDecodedStringJpg :: B.ByteString -> BoolReader s () +setDecodedStringJpg str = case B.uncons str of + Nothing -> S.put $ BoolState maxBound 0 B.empty + Just (0xFF, rest) -> case B.uncons rest of + Nothing -> S.put $ BoolState maxBound 0 B.empty + Just (0x00, afterMarker) -> -- trace "00" $ + S.put $ BoolState 7 0xFF afterMarker + Just (_ , afterMarker) -> setDecodedStringJpg afterMarker + Just (v, rest) -> + S.put $ BoolState 7 v rest + +-------------------------------------------------- +---- Writer +-------------------------------------------------- +defaultBufferSize :: Int +defaultBufferSize = 256 * 1024 + +data BoolWriteStateRef s = BoolWriteStateRef + { bwsCurrBuffer :: STRef s (M.MVector s Word8) + , bwsBufferList :: STRef s [B.ByteString] + , bwsWrittenWords :: STRef s Int + , bwsBitAcc :: STRef s Word8 + , bwsBitReaded :: STRef s Int + } + +newWriteStateRef :: ST s (BoolWriteStateRef s) +newWriteStateRef = do + origMv <- M.new defaultBufferSize + BoolWriteStateRef <$> newSTRef origMv + <*> newSTRef [] + <*> newSTRef 0 + <*> newSTRef 0 + <*> newSTRef 0 + +finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString +finalizeBoolWriter st = do + forceBufferFlushing' st + L.fromChunks <$> readSTRef (bwsBufferList st) + +forceBufferFlushing' :: BoolWriteStateRef s -> ST s () +forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef + , bwsWrittenWords = countRef + , bwsBufferList = lstRef + }) = do + vec <- readSTRef vecRef + count <- readSTRef countRef + lst <- readSTRef lstRef + + nmv <- M.new defaultBufferSize + str <- byteStringFromVector vec count + + writeSTRef vecRef nmv + writeSTRef lstRef $ lst ++ [str] + writeSTRef countRef 0 + +flushCurrentBuffer' :: BoolWriteStateRef s -> ST s () +flushCurrentBuffer' st = do + count <- readSTRef $ bwsWrittenWords st + when (count >= defaultBufferSize) + (forceBufferFlushing' st) + +byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString +byteStringFromVector vec size = do + frozen <- VS.unsafeFreeze vec + return $ blitVector frozen 0 size + +setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s () +{-# INLINE setBitCount' #-} +setBitCount' st acc count = do + writeSTRef (bwsBitAcc st) acc + writeSTRef (bwsBitReaded st) count + +resetBitCount' :: BoolWriteStateRef s -> ST s () +{-# INLINE resetBitCount' #-} +resetBitCount' st = setBitCount' st 0 0 + +pushByte' :: BoolWriteStateRef s -> Word8 -> ST s () +{-# INLINE pushByte' #-} +pushByte' st v = do + flushCurrentBuffer' st + idx <- readSTRef (bwsWrittenWords st) + vec <- readSTRef (bwsCurrBuffer st) + M.write vec idx v + writeSTRef (bwsWrittenWords st) $ idx + 1 + +-- | Append some data bits to a Put monad. +writeBits' :: BoolWriteStateRef s + -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB + -> Int -- ^ Number of bit to write from 1 to 32 + -> ST s () +{-# INLINE writeBits' #-} +writeBits' st d c = do + currWord <- readSTRef $ bwsBitAcc st + currCount <- readSTRef $ bwsBitReaded st + serialize d c currWord currCount + where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00 + dumpByte i = pushByte' st i + + serialize bitData bitCount currentWord count + | bitCount + count == 8 = do + resetBitCount' st + dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|. + fromIntegral cleanData) + + | bitCount + count < 8 = + let newVal = currentWord `unsafeShiftL` bitCount + in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount + + | otherwise = + let leftBitCount = 8 - count :: Int + highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32 + prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32 + + nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32 + newData = cleanData .&. nextMask :: Word32 + newCount = bitCount - leftBitCount :: Int + + toWrite = fromIntegral $ prevPart .|. highPart :: Word8 + in dumpByte toWrite >> serialize newData newCount 0 0 + + where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 + cleanData = bitData .&. cleanMask :: Word32 + +-- | Append some data bits to a Put monad. +writeBitsGif :: BoolWriteStateRef s + -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB + -> Int -- ^ Number of bit to write from 1 to 32 + -> ST s () +{-# INLINE writeBitsGif #-} +writeBitsGif st d c = do + currWord <- readSTRef $ bwsBitAcc st + currCount <- readSTRef $ bwsBitReaded st + serialize d c currWord currCount + where dumpByte i = pushByte' st i + + serialize bitData bitCount currentWord count + | bitCount + count == 8 = do + resetBitCount' st + dumpByte (fromIntegral $ currentWord .|. + (fromIntegral cleanData `unsafeShiftL` count)) + + | bitCount + count < 8 = + let newVal = fromIntegral cleanData `unsafeShiftL` count + in setBitCount' st (newVal .|. currentWord) $ count + bitCount + + | otherwise = + let leftBitCount = 8 - count :: Int + newData = cleanData `unsafeShiftR` leftBitCount :: Word32 + newCount = bitCount - leftBitCount :: Int + toWrite = fromIntegral $ fromIntegral currentWord + .|. (cleanData `unsafeShiftL` count) :: Word8 + in dumpByte toWrite >> serialize newData newCount 0 0 + + where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 + cleanData = bitData .&. cleanMask :: Word32 + diff --git a/src/Codec/Picture/Bitmap.hs b/src/Codec/Picture/Bitmap.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Bitmap.hs @@ -0,0 +1,350 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- | Modules used for Bitmap file (.bmp) file loading and writing +module Codec.Picture.Bitmap( -- * Functions + writeBitmap + , encodeBitmap + , decodeBitmap + , encodeDynamicBitmap + , writeDynamicBitmap + -- * Accepted formt in output + , BmpEncodable( ) + ) where +import Control.Monad( when, forM_ ) +import Control.Monad.ST ( ST, runST ) +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M +import Data.Binary( Binary( .. ) ) +import Data.Binary.Put( Put + , runPut + , putWord16le + , putWord32le + , putByteString + ) + +import Data.Binary.Get( Get + , getWord16le + , getWord32le + , bytesRead + , skip + ) + +import Data.Word( Word32, Word16, Word8 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.VectorByteConversion + +data BmpHeader = BmpHeader + { magicIdentifier :: !Word16 + , fileSize :: !Word32 -- ^ in bytes + , reserved1 :: !Word16 + , reserved2 :: !Word16 + , dataOffset :: !Word32 + } + +bitmapMagicIdentifier :: Word16 +bitmapMagicIdentifier = 0x4D42 + +instance Binary BmpHeader where + put hdr = do + putWord16le $ magicIdentifier hdr + putWord32le $ fileSize hdr + putWord16le $ reserved1 hdr + putWord16le $ reserved2 hdr + putWord32le $ dataOffset hdr + + get = do + ident <- getWord16le + when (ident /= bitmapMagicIdentifier) + (fail "Invalid Bitmap magic identifier") + fsize <- getWord32le + r1 <- getWord16le + r2 <- getWord16le + offset <- getWord32le + return BmpHeader + { magicIdentifier = ident + , fileSize = fsize + , reserved1 = r1 + , reserved2 = r2 + , dataOffset = offset + } + + +data BmpInfoHeader = BmpInfoHeader + { size :: !Word32 -- Header size in bytes + , width :: !Word32 + , height :: !Word32 + , planes :: !Word16 -- Number of colour planes + , bitPerPixel :: !Word16 + , bitmapCompression :: !Word32 + , byteImageSize :: !Word32 + , xResolution :: !Word32 -- ^ Pixels per meter + , yResolution :: !Word32 -- ^ Pixels per meter + , colorCount :: !Word32 + , importantColours :: !Word32 + } + +sizeofBmpHeader, sizeofBmpInfo :: Word32 +sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 +sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 + +instance Binary BmpInfoHeader where + put hdr = do + putWord32le $ size hdr + putWord32le $ width hdr + putWord32le $ height hdr + putWord16le $ planes hdr + putWord16le $ bitPerPixel hdr + putWord32le $ bitmapCompression hdr + putWord32le $ byteImageSize hdr + putWord32le $ xResolution hdr + putWord32le $ yResolution hdr + putWord32le $ colorCount hdr + putWord32le $ importantColours hdr + + get = do + readSize <- getWord32le + readWidth <- getWord32le + readHeight <- getWord32le + readPlanes <- getWord16le + readBitPerPixel <- getWord16le + readBitmapCompression <- getWord32le + readByteImageSize <- getWord32le + readXResolution <- getWord32le + readYResolution <- getWord32le + readColorCount <- getWord32le + readImportantColours <- getWord32le + return BmpInfoHeader { + size = readSize, + width = readWidth, + height = readHeight, + planes = readPlanes, + bitPerPixel = readBitPerPixel, + bitmapCompression = readBitmapCompression, + byteImageSize = readByteImageSize, + xResolution = readXResolution, + yResolution = readYResolution, + colorCount = readColorCount, + importantColours = readImportantColours + } + +newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)] + +putPalette :: BmpPalette -> Put +putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p + +-- | All the instance of this class can be written as a bitmap file +-- using this library. +class BmpEncodable pixel where + bitsPerPixel :: pixel -> Int + bmpEncode :: Image pixel -> Put + defaultPalette :: pixel -> BmpPalette + defaultPalette _ = BmpPalette [] + +stridePut :: M.STVector s Word8 -> Int -> Int -> ST s () +{-# INLINE stridePut #-} +stridePut vec = inner + where inner _ 0 = return () + inner ix n = do + (vec `M.unsafeWrite` ix) 0 + inner (ix + 1) (n - 1) + +instance BmpEncodable Pixel8 where + defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]] + bitsPerPixel _ = 8 + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l + where stride = fromIntegral $ linePadding 8 w + putVector vec = putByteString $ blitVector vec 0 lineWidth + lineWidth = w + stride + + encodeLine line = do + buff <- M.new lineWidth + + let lineIdx = line * w + inner col | col >= w = return () + inner col = do + let v = (arr `V.unsafeIndex` (lineIdx + col)) + (buff `M.unsafeWrite` col) v + inner (col + 1) + + inner 0 + + stridePut buff w stride + V.unsafeFreeze buff + +instance BmpEncodable PixelRGBA8 where + bitsPerPixel _ = 32 + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l + where putVector vec = putByteString . blitVector vec 0 $ w * 4 + putLine line = do + buff <- M.new $ 4 * w + let initialIndex = line * w * 4 + inner col _ _ | col >= w = return () + inner col writeIdx readIdx = do + let r = arr `V.unsafeIndex` readIdx + g = arr `V.unsafeIndex` (readIdx + 1) + b = arr `V.unsafeIndex` (readIdx + 2) + a = arr `V.unsafeIndex` (readIdx + 3) + + (buff `M.unsafeWrite` writeIdx) b + (buff `M.unsafeWrite` (writeIdx + 1)) g + (buff `M.unsafeWrite` (writeIdx + 2)) r + (buff `M.unsafeWrite` (writeIdx + 3)) a + + inner (col + 1) (writeIdx + 4) (readIdx + 4) + + inner 0 0 initialIndex + V.unsafeFreeze buff + +instance BmpEncodable PixelRGB8 where + bitsPerPixel _ = 24 + bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = + forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l + where stride = fromIntegral . linePadding 24 $ w + putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride) + putLine line = do + buff <- M.new $ w * 3 + stride + let initialIndex = line * w * 3 + inner col _ _ | col >= w = return () + inner col writeIdx readIdx = do + let r = (arr `V.unsafeIndex` readIdx) + g = (arr `V.unsafeIndex` (readIdx + 1)) + b = (arr `V.unsafeIndex` (readIdx + 2)) + + (buff `M.unsafeWrite` writeIdx) b + (buff `M.unsafeWrite` (writeIdx + 1)) g + (buff `M.unsafeWrite` (writeIdx + 2)) r + + inner (col + 1) (writeIdx + 3) (readIdx + 3) + + inner 0 0 initialIndex + V.unsafeFreeze buff + +decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 +decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray + where wi = fromIntegral w + hi = fromIntegral h + stArray = runST $ do + arr <- M.new (fromIntegral $ w * h * 3) + forM_ [hi - 1, hi - 2 .. 0] (readLine arr) + V.unsafeFreeze arr + + stride = linePadding 24 wi + readLine arr line = + let readIndex = (wi * 3 + stride) * line + lastIndex = wi * (hi - 1 - line + 1) * 3 + writeIndex = wi * (hi - 1 - line) * 3 + + inner _ writeIdx | writeIdx >= lastIndex = return () + inner readIdx writeIdx = do + (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + 2)) + (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1)) + (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` readIdx) + inner (readIdx + 3) (writeIdx + 3) + + in inner readIndex writeIndex + + +-- | Try to decode a bitmap image. +-- Right now this function can output the following pixel types : +-- +-- * PixelRGB8 +-- +decodeBitmap :: B.ByteString -> Either String DynamicImage +decodeBitmap str = flip runGetStrict str $ do + hdr <- get :: Get BmpHeader + bmpHeader <- get :: Get BmpInfoHeader + case (bitPerPixel bmpHeader, planes bmpHeader, + bitmapCompression bmpHeader) of + -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" + (24, 1, 0) -> do + readed <- bytesRead + + when (readed > fromIntegral (dataOffset hdr)) + (fail "Invalid bmp image, data in header") + + skip . fromIntegral $ dataOffset hdr - fromIntegral readed + rest <- getRemainingBytes + return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest + a -> fail $ "Can't handle BMP file " ++ show a + + +-- | Write an image in a file use the bitmap format. +writeBitmap :: (BmpEncodable pixel) + => FilePath -> Image pixel -> IO () +writeBitmap filename img = L.writeFile filename $ encodeBitmap img + +linePadding :: Int -> Int -> Int +linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 + where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8) + +-- | Encode an image into a bytestring in .bmp format ready to be written +-- on disk. +encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString +encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) + + +-- | Write a dynamic image in a .bmp image file if possible. +-- The same restriction as encodeDynamicBitmap apply. +writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) +writeDynamicBitmap path img = case encodeDynamicBitmap img of + Left err -> return $ Left err + Right b -> L.writeFile path b >> return (Right True) + +-- | Encode a dynamic image in bmp if possible, supported pixel type are : +-- +-- - RGB8 +-- +-- - RGBA8 +-- +-- - Y8 +-- +encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString +encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img +encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img +encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img +encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" + + +-- | Convert an image to a bytestring ready to be serialized. +encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) + => BmpPalette -> Image pixel -> L.ByteString +encodeBitmapWithPalette pal@(BmpPalette palette) img = + runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img + where imgWidth = fromIntegral $ imageWidth img + imgHeight = fromIntegral $ imageHeight img + + paletteSize = fromIntegral $ length palette + bpp = bitsPerPixel (undefined :: pixel) + padding = linePadding bpp (imgWidth + 1) + imagePixelSize = fromIntegral $ (imgWidth + padding) * imgHeight * 4 + hdr = BmpHeader { + magicIdentifier = bitmapMagicIdentifier, + fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize, + reserved1 = 0, + reserved2 = 0, + dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + } + + info = BmpInfoHeader { + size = sizeofBmpInfo, + width = fromIntegral imgWidth, + height = fromIntegral imgHeight, + planes = 1, + bitPerPixel = fromIntegral bpp, + bitmapCompression = 0, -- no compression + byteImageSize = imagePixelSize, + xResolution = 0, + yResolution = 0, + colorCount = 0, + importantColours = paletteSize + } + + diff --git a/src/Codec/Picture/ColorQuant.hs b/src/Codec/Picture/ColorQuant.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/ColorQuant.hs @@ -0,0 +1,380 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE BangPatterns #-} +-- | This module provide some color quantisation algorithm +-- in order to help in the creation of paletted images. +-- The most important function is `palettize` which will +-- make everything to create a nice color indexed image +-- with its palette. +module Codec.Picture.ColorQuant + ( palettize + , defaultPaletteOptions + , PaletteCreationMethod(..) + , PaletteOptions( .. ) + ) where + +import Control.Applicative (Applicative (..), (<$>)) +import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) +import Data.List (elemIndex) +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word (Word32) + +import Data.Vector (Vector, (!)) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS + +import Codec.Picture.Types + +------------------------------------------------------------------------------- +---- Palette Creation and Dithering +------------------------------------------------------------------------------- + +-- | Define which palette creation method is used. +data PaletteCreationMethod = + -- | MedianMeanCut method, provide the best results (visualy) + -- at the cost of increased calculations. + MedianMeanCut + -- | Very fast algorithm (one pass), doesn't provide good + -- looking results. + | Uniform + +-- | To specify how the palette will be created. +data PaletteOptions = PaletteOptions + { -- | Algorithm used to find the palette + paletteCreationMethod :: PaletteCreationMethod + + -- | Do we want to apply the dithering to the + -- image. Enabling it often reduce compression + -- ratio but enhance the perceived quality + -- of the final image. + , enableImageDithering :: Bool + + -- | Maximum number of color we want in the + -- palette + , paletteColorCount :: Int + } + +-- | Default palette option, which aim at the best quality +-- and maximum possible colors (256) +defaultPaletteOptions :: PaletteOptions +defaultPaletteOptions = PaletteOptions + { paletteCreationMethod = MedianMeanCut + , enableImageDithering = True + , paletteColorCount = 256 + } + +-- | Reduces an image to a color palette according to `PaletteOpts` and +-- returns the /indices image/ along with its `Palette`. +palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) +palettize opts@PaletteOptions { paletteCreationMethod = method } = + case method of + MedianMeanCut -> medianMeanCutQuantization opts + Uniform -> uniformQuantization opts + +-- | Modified median cut algorithm with optional ordered dithering. Returns an +-- image of `Pixel8` that acts as a matrix of indices into the `Palette`. +medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8 + -> (Image Pixel8, Palette) +medianMeanCutQuantization opts img + | isBelow = + (pixelMap okPaletteIndex img, vecToPalette okPaletteVec) + | enableImageDithering opts = (pixelMap paletteIndex dImg, palette) + | otherwise = (pixelMap paletteIndex img, palette) + where + maxColorCount = paletteColorCount opts + (okPalette, isBelow) = isColorCountBelow maxColorCount img + okPaletteVec = V.fromList $ Set.toList okPalette + okPaletteIndex p = nearestColorIdx p okPaletteVec + + palette = vecToPalette paletteVec + paletteIndex p = nearestColorIdx p paletteVec + paletteVec = mkPaletteVec cs + cs = Set.toList . clusters maxColorCount $ img + dImg = pixelMapXY dither img + +-- | A naive one pass Color Quantiation algorithm - Uniform Quantization. +-- Simply take the most significant bits. The maxCols parameter is rounded +-- down to the nearest power of 2, and the bits are divided among the three +-- color channels with priority order green, red, blue. Returns an +-- image of `Pixel8` that acts as a matrix of indices into the `Palette`. +uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) +uniformQuantization opts img + -- -| colorCount img <= maxCols = colorQuantExact img + | enableImageDithering opts = + (pixelMap paletteIndex (pixelMapXY dither img), palette) + | otherwise = (pixelMap paletteIndex img, palette) + where + maxCols = paletteColorCount opts + palette = listToPalette paletteList + paletteList = [PixelRGB8 r g b | r <- [0,dr..255] + , g <- [0,dg..255] + , b <- [0,db..255]] + (bg, br, bb) = bitDiv3 maxCols + (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb)) + paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex + (PixelRGB8 (r .&. (256 - dr)) (g .&. (256 - dg)) (b .&. (256 - db))) + paletteList) + +isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool) +isColorCountBelow maxColorCount img = go 0 0 Set.empty + where rawData = imageData img + maxIndex = VS.length rawData + + go !count !idx !allColors + | count > maxColorCount = (Set.empty, False) + | idx >= maxIndex - 2 = (allColors, True) + | otherwise = go (count + 1) (idx + 3) + $ Set.insert px allColors + where px = unsafePixelAt rawData idx + +vecToPalette :: Vector PixelRGB8 -> Palette +vecToPalette ps = generateImage (\x _ -> ps ! x) (V.length ps) 1 + +listToPalette :: [PixelRGB8] -> Palette +listToPalette ps = generateImage (\x _ -> ps !! x) (length ps) 1 + +bitDiv3 :: Int -> (Int, Int, Int) +bitDiv3 n = case r of + 0 -> (q, q, q) + 1 -> (q+1, q, q) + _ -> (q+1, q+1, q) + where + r = m `mod` 3 + q = m `div` 3 + m = floor . logBase (2 :: Double) $ fromIntegral n + +------------------------------------------------------------------------------- +---- Dithering +------------------------------------------------------------------------------- + +-- Add a dither mask to an image for ordered dithering. +-- Uses a small, spatially stable dithering algorithm based on magic numbers +-- and arithmetic inspired by the /a dither/ algorithm of Øyvind Kolås, +-- pippin@gimp.org, 2013. See, http://pippin.gimp.org/a_dither/. +dither :: Int -> Int -> PixelRGB8 -> PixelRGB8 +dither x y (PixelRGB8 r g b) = PixelRGB8 (fromIntegral r') + (fromIntegral g') + (fromIntegral b') + where + -- Should view 16 as a parameter that can be optimized for best looking + -- results + r' = min 255 (fromIntegral r + (x' + y') .&. 16) + g' = min 255 (fromIntegral g + (x' + y' + 7973) .&. 16) + b' = min 255 (fromIntegral b + (x' + y' + 15946) .&. 16) + x' = 119 * x + y' = 28084 * y + +------------------------------------------------------------------------------- +---- Small modification of foldl package by Gabriel Gonzalez +------------------------------------------------------------------------------- + +-- Modification to Control.foldl by Gabriel Gonzalez copyright 2013, BSD3. +-- http://hackage.haskell.org/package/foldl-1.0.1/docs/Control-Foldl.html + +{-| Efficient representation of a left fold that preserves the fold's step + function, initial accumulator, and extraction function + + This allows the 'Applicative' instance to assemble derived folds that + traverse the container only once +-} +data Fold a b = forall x . Fold (x -> a -> x) x (x -> b) + +{-| Apply a strict left 'Fold' to a 'Foldable' container + + Much slower than 'fold' on lists because 'Foldable' operations currently do + not trigger @build/foldr@ fusion +-} +fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b +fold (Fold step begin done) = done . VU.foldl' step begin +{-# INLINE fold #-} + +{- +F.foldr :: (a -> b -> b) -> b -> t a -> b + +fold :: (Foldable f) => Fold a b -> f a -> b +fold (Fold step begin done) as = F.foldr step' done as begin + where step' x k z = k $! step z x +-} + +data Pair a b = Pair !a !b + +instance Functor (Fold a) where + fmap f (Fold step begin done) = Fold step begin (f . done) + {-# INLINABLE fmap #-} + +instance Applicative (Fold a) where + pure b = Fold (\() _ -> ()) () (\() -> b) + {-# INLINABLE pure #-} + (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = + let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) + begin = Pair beginL beginR + done (Pair xL xR) = (doneL xL) (doneR xR) + in Fold step begin done + {-# INLINABLE (<*>) #-} + +{- | Like 'length', except with a more general 'Num' return value -} +intLength :: Fold a Int +intLength = Fold (\n _ -> n + 1) 0 id + +------------------------------------------------------------------------------- +---- Modified Median Cut Algorithm +------------------------------------------------------------------------------- + +-- Based on the OCaml implementation: +-- http://rosettacode.org/wiki/Color_quantization +-- which is in turn based on: www.leptonica.com/papers/mediancut.pdf. +-- We use the product of volume and population to determine the next cluster +-- to split and determine the placement of each color by compating it to the +-- mean of the parent cluster. So median cut is a bit of a misnomer, since one +-- of the modifiations is to use the mean. + +mkPaletteVec :: [Cluster] -> Vector PixelRGB8 +mkPaletteVec = V.fromList . map (toRGB8 . meanColor) + +type PackedRGB = Word32 + +data Cluster = Cluster + { value :: {-# UNPACK #-} !Float + , meanColor :: !PixelRGBF + , dims :: !PixelRGBF + , colors :: VU.Vector PackedRGB + } + +instance Eq Cluster where + a == b = + (value a, meanColor a, dims a) == (value b, meanColor b, dims b) + +instance Ord Cluster where + compare a b = + compare (value a, meanColor a, dims a) (value b, meanColor b, dims b) + +data Axis = RAxis | GAxis | BAxis + +inf :: Float +inf = read "Infinity" + +fromRGB8 :: PixelRGB8 -> PixelRGBF +fromRGB8 (PixelRGB8 r g b) = + PixelRGBF (fromIntegral r) (fromIntegral g) (fromIntegral b) + +toRGB8 :: PixelRGBF -> PixelRGB8 +toRGB8 (PixelRGBF r g b) = + PixelRGB8 (round r) (round g) (round b) + +meanRGB :: Fold PixelRGBF PixelRGBF +meanRGB = mean <$> intLength <*> pixelSum + where + pixelSum = Fold (mixWith $ const (+)) (PixelRGBF 0 0 0) id + mean n = colorMap (/ nf) + where nf = fromIntegral n + +minimal :: Fold PixelRGBF PixelRGBF +minimal = Fold mini (PixelRGBF inf inf inf) id + where mini = mixWith $ const min + +maximal :: Fold PixelRGBF PixelRGBF +maximal = Fold maxi (PixelRGBF (-inf) (-inf) (-inf)) id + where maxi = mixWith $ const max + +extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF) +extrems = (,) <$> minimal <*> maximal + +volAndDims :: Fold PixelRGBF (Float, PixelRGBF) +volAndDims = deltify <$> extrems + where deltify (mini, maxi) = (dr * dg * db, delta) + where delta@(PixelRGBF dr dg db) = + mixWith (const (-)) maxi mini + +unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a +unpackFold (Fold step start done) = Fold (\acc -> step acc . transform) start done + where transform = fromRGB8 . rgbIntUnpack + +mkCluster :: VU.Vector PackedRGB -> Cluster +mkCluster ps = Cluster + { value = v * fromIntegral l + , meanColor = m + , dims = ds + , colors = ps + } + where + worker = (,,) <$> volAndDims <*> meanRGB <*> intLength + ((v, ds), m, l) = fold (unpackFold worker) ps + +maxAxis :: PixelRGBF -> Axis +maxAxis (PixelRGBF r g b) = + case (r `compare` g, r `compare` b, g `compare` b) of + (GT, GT, _) -> RAxis + (LT, GT, _) -> GAxis + (GT, LT, _) -> BAxis + (LT, LT, GT) -> GAxis + (_, _, _) -> BAxis + +-- Split a cluster about its largest axis using the mean to divide up the +-- pixels. +subdivide :: Cluster -> (Cluster, Cluster) +subdivide cluster = (mkCluster px1, mkCluster px2) + where + (PixelRGBF mr mg mb) = meanColor cluster + (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster + cond = case maxAxis $ dims cluster of + RAxis -> (\(PixelRGB8 r _ _) -> fromIntegral r < mr) + GAxis -> (\(PixelRGB8 _ g _) -> fromIntegral g < mg) + BAxis -> (\(PixelRGB8 _ _ b) -> fromIntegral b < mb) + +rgbIntPack :: PixelRGB8 -> PackedRGB +rgbIntPack (PixelRGB8 r g b) = + wr `unsafeShiftL` (2 * 8) .|. wg `unsafeShiftL` 8 .|. wb + where wr = fromIntegral r + wg = fromIntegral g + wb = fromIntegral b + +rgbIntUnpack :: PackedRGB -> PixelRGB8 +rgbIntUnpack v = PixelRGB8 r g b + where + r = fromIntegral $ v `unsafeShiftR` (2 * 8) + g = fromIntegral $ v `unsafeShiftR` 8 + b = fromIntegral $ v + +initCluster :: Image PixelRGB8 -> Cluster +initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer + where samplingFactor = 3 + subSampling = samplingFactor * samplingFactor + compCount = componentCount (undefined :: PixelRGB8) + w = imageWidth img + h = imageHeight img + rawData = imageData img + packer ix = + rgbIntPack . unsafePixelAt rawData $ ix * subSampling * compCount + +-- Take the cluster with the largest value = (volume * population) and remove it +-- from the priority queue. Then subdivide it about its largest axis and put the +-- two new clusters on the queue. +split :: Set Cluster -> Set Cluster +split cs = Set.insert c1 . Set.insert c2 $ cs' + where + (c, cs') = Set.deleteFindMax cs + (c1, c2) = subdivide c + +-- Keep splitting the initial cluster until there are 256 clusters, then return +-- a priority queue containing all 256. +clusters :: Int -> Image PixelRGB8 -> Set Cluster +clusters maxCols img = clusters' (maxCols - 1) + where + clusters' :: Int -> Set Cluster + clusters' 0 = Set.singleton c + clusters' n = split (clusters' (n-1)) + c = initCluster img + +-- Euclidean distance squared, between two pixels. +dist2Px :: PixelRGB8 -> PixelRGB8 -> Int +dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db + where + (dr, dg, db) = + ( fromIntegral r1 - fromIntegral r2 + , fromIntegral g1 - fromIntegral g2 + , fromIntegral b1 - fromIntegral b2 ) + +nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8 +nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (\px -> dist2Px px p) ps) diff --git a/src/Codec/Picture/ConvGraph.hs b/src/Codec/Picture/ConvGraph.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/ConvGraph.hs @@ -0,0 +1,9 @@ +-- $graph +-- +-- The following graph describe the differents way to convert between pixel types, +-- +-- * Nodes describe pixel type +-- +-- * Arrows describe functions +-- +-- <> diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Gif.hs @@ -0,0 +1,685 @@ +-- | Module implementing GIF decoding. +module Codec.Picture.Gif ( -- * Reading + decodeGif + , decodeGifImages + + -- * Writing + , GifDelay + , GifLooping( .. ) + , encodeGifImage + , encodeGifImageWithPalette + , encodeGifImages + + , writeGifImage + , writeGifImageWithPalette + , writeGifImages + , greyPalette + ) where + +import Control.Applicative( pure, (<$>), (<*>) ) +import Control.Monad( replicateM, replicateM_ ) +import Control.Monad.ST( runST ) +import Control.Monad.Trans.Class( lift ) + +import Data.Bits( (.&.), (.|.) + , unsafeShiftR + , unsafeShiftL + , testBit, setBit ) +import Data.Word( Word8, Word16 ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +import Data.Binary( Binary(..), encode ) +import Data.Binary.Get( Get + , getWord8 + , getWord16le + , getByteString + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16le + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.Gif.LZW +import Codec.Picture.Gif.LZWEncoding +import Codec.Picture.BitWriter + +-- | Delay to wait before showing the next Gif image. +-- The delay is expressed in 100th of seconds. +type GifDelay = Int + +-- | Help to control the behaviour of GIF animation looping. +data GifLooping = + -- | The animation will stop once the end is reached + LoopingNever + -- | The animation will restart once the end is reached + | LoopingForever + -- | The animation will repeat n times before stoping + | LoopingRepeat Word16 + +{- + ::= Header * Trailer + + ::= Logical Screen Descriptor [Global Color Table] + + ::= | + + + ::= [Graphic Control Extension] + + ::= | + Plain Text Extension + + ::= Image Descriptor [Local Color Table] Image Data + + ::= Application Extension | + Comment Extension + -} + +-------------------------------------------------- +---- GifVersion +-------------------------------------------------- +data GifVersion = GIF87a | GIF89a + +gif87aSignature, gif89aSignature :: B.ByteString +gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" +gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" + +instance Binary GifVersion where + put GIF87a = putByteString gif87aSignature + put GIF89a = putByteString gif89aSignature + + get = do + sig <- getByteString (B.length gif87aSignature) + case (sig == gif87aSignature, sig == gif89aSignature) of + (True, _) -> pure GIF87a + (_ , True) -> pure GIF89a + _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) + + +-------------------------------------------------- +---- LogicalScreenDescriptor +-------------------------------------------------- +-- | Section 18 of spec-gif89a +data LogicalScreenDescriptor = LogicalScreenDescriptor + { -- | Stored on 16 bits + screenWidth :: !Word16 + -- | Stored on 16 bits + , screenHeight :: !Word16 + -- | Stored on 8 bits + , backgroundIndex :: !Word8 + + -- | Stored on 1 bit + , hasGlobalMap :: !Bool + -- | Stored on 3 bits + , colorResolution :: !Word8 + -- | Stored on 1 bit + , isColorTableSorted :: !Bool + -- | Stored on 3 bits + , colorTableSize :: !Word8 + } + +instance Binary LogicalScreenDescriptor where + put v = do + putWord16le $ screenWidth v + putWord16le $ screenHeight v + let globalMapField + | hasGlobalMap v = 0x80 + | otherwise = 0 + + colorTableSortedField + | isColorTableSorted v = 0x08 + | otherwise = 0 + + tableSizeField = (colorTableSize v - 1) .&. 7 + + colorResolutionField = + ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 + + packedField = globalMapField + .|. colorTableSortedField + .|. tableSizeField + .|. colorResolutionField + + putWord8 packedField + putWord8 0 -- aspect ratio + putWord8 $ backgroundIndex v + + get = do + w <- getWord16le + h <- getWord16le + packedField <- getWord8 + backgroundColorIndex <- getWord8 + _aspectRatio <- getWord8 + return LogicalScreenDescriptor + { screenWidth = w + , screenHeight = h + , hasGlobalMap = packedField `testBit` 7 + , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 + , isColorTableSorted = packedField `testBit` 3 + , colorTableSize = (packedField .&. 0x7) + 1 + , backgroundIndex = backgroundColorIndex + } + + +-------------------------------------------------- +---- ImageDescriptor +-------------------------------------------------- +-- | Section 20 of spec-gif89a +data ImageDescriptor = ImageDescriptor + { gDescPixelsFromLeft :: !Word16 + , gDescPixelsFromTop :: !Word16 + , gDescImageWidth :: !Word16 + , gDescImageHeight :: !Word16 + , gDescHasLocalMap :: !Bool + , gDescIsInterlaced :: !Bool + , gDescIsImgDescriptorSorted :: !Bool + , gDescLocalColorTableSize :: !Word8 + } + +imageSeparator, extensionIntroducer, gifTrailer, applicationLabel :: Word8 +imageSeparator = 0x2C +extensionIntroducer = 0x21 +gifTrailer = 0x3B +applicationLabel = 0xFF + +graphicControlLabel :: Word8 +graphicControlLabel = 0xF9 + +--commentLabel, graphicControlLabel, +-- +{-commentLabel = 0xFE-} +{-plainTextLabel = 0x01-} + +parseDataBlocks :: Get B.ByteString +parseDataBlocks = B.concat <$> (getWord8 >>= aux) + where aux 0 = pure [] + aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) + +putDataBlocks :: B.ByteString -> Put +putDataBlocks wholeString = putSlices wholeString >> putWord8 0 + where putSlices str | B.length str == 0 = pure () + | B.length str > 0xFF = + let (before, after) = B.splitAt 0xFF str in + putWord8 0xFF >> putByteString before >> putSlices after + putSlices str = + putWord8 (fromIntegral $ B.length str) >> putByteString str + + +data GraphicControlExtension = GraphicControlExtension + { gceDisposalMethod :: !Word8 -- ^ Stored on 3 bits + , gceUserInputFlag :: !Bool + , gceTransparentFlag :: !Bool + , gceDelay :: !Word16 + , gceTransparentColorIndex :: !Word8 + } + +instance Binary GraphicControlExtension where + put v = do + putWord8 extensionIntroducer + putWord8 graphicControlLabel + putWord8 0x4 -- size + let disposalField = + (gceDisposalMethod v .&. 0x7) `unsafeShiftL` 2 + + userInputField + | gceUserInputFlag v = 0 `setBit` 1 + | otherwise = 0 + + transparentField + | gceTransparentFlag v = 0 `setBit` 0 + | otherwise = 0 + + packedFields = disposalField + .|. userInputField + .|. transparentField + + putWord8 packedFields + putWord16le $ gceDelay v + putWord8 $ gceTransparentColorIndex v + putWord8 0 -- blockTerminator + + get = do + -- due to missing lookahead + {-_extensionLabel <- getWord8-} + _size <- getWord8 + packedFields <- getWord8 + delay <- getWord16le + idx <- getWord8 + _blockTerminator <- getWord8 + return GraphicControlExtension + { gceDisposalMethod = (packedFields `unsafeShiftR` 2) .&. 0x07 + , gceUserInputFlag = packedFields `testBit` 1 + , gceTransparentFlag = packedFields `testBit` 0 + , gceDelay = delay + , gceTransparentColorIndex = idx + } + +data GifImage = GifImage + { imgDescriptor :: !ImageDescriptor + , imgLocalPalette :: !(Maybe Palette) + , imgLzwRootSize :: !Word8 + , imgData :: B.ByteString + } + +instance Binary GifImage where + put img = do + let descriptor = imgDescriptor img + put descriptor + case ( imgLocalPalette img + , gDescHasLocalMap $ imgDescriptor img) of + (Nothing, _) -> return () + (Just _, False) -> return () + (Just p, True) -> + putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p + putWord8 $ imgLzwRootSize img + putDataBlocks $ imgData img + + get = do + desc <- get + let hasLocalColorTable = gDescHasLocalMap desc + palette <- if hasLocalColorTable + then Just <$> getPalette (gDescLocalColorTableSize desc) + else pure Nothing + + GifImage desc palette <$> getWord8 <*> parseDataBlocks + +data Block = BlockImage GifImage + | BlockGraphicControl GraphicControlExtension + +parseGifBlocks :: Get [Block] +parseGifBlocks = getWord8 >>= blockParse + where blockParse v + | v == gifTrailer = pure [] + | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks + | v == extensionIntroducer = do + extensionCode <- getWord8 + if extensionCode /= graphicControlLabel + then parseDataBlocks >> parseGifBlocks + else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + + blockParse v = do + fail ("Unrecognized gif block " ++ show v) + +instance Binary ImageDescriptor where + put v = do + putWord8 imageSeparator + putWord16le $ gDescPixelsFromLeft v + putWord16le $ gDescPixelsFromTop v + putWord16le $ gDescImageWidth v + putWord16le $ gDescImageHeight v + let localMapField + | gDescHasLocalMap v = 0 `setBit` 7 + | otherwise = 0 + + isInterlacedField + | gDescIsInterlaced v = 0 `setBit` 6 + | otherwise = 0 + + isImageDescriptorSorted + | gDescIsImgDescriptorSorted v = 0 `setBit` 5 + | otherwise = 0 + + localSize = gDescLocalColorTableSize v + tableSizeField + | localSize > 0 = (localSize - 1) .&. 0x7 + | otherwise = 0 + + packedFields = localMapField + .|. isInterlacedField + .|. isImageDescriptorSorted + .|. tableSizeField + putWord8 packedFields + + get = do + -- due to missing lookahead + {-_imageSeparator <- getWord8-} + imgLeftPos <- getWord16le + imgTopPos <- getWord16le + imgWidth <- getWord16le + imgHeight <- getWord16le + packedFields <- getWord8 + let tableSize = packedFields .&. 0x7 + return ImageDescriptor + { gDescPixelsFromLeft = imgLeftPos + , gDescPixelsFromTop = imgTopPos + , gDescImageWidth = imgWidth + , gDescImageHeight = imgHeight + , gDescHasLocalMap = packedFields `testBit` 7 + , gDescIsInterlaced = packedFields `testBit` 6 + , gDescIsImgDescriptorSorted = packedFields `testBit` 5 + , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 + } + + +-------------------------------------------------- +---- Palette +-------------------------------------------------- +getPalette :: Word8 -> Get Palette +getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList + where size = 2 ^ (fromIntegral bitDepth :: Int) + +putPalette :: Int -> Palette -> Put +putPalette size pal = do + V.mapM_ putWord8 (imageData pal) + replicateM_ missingColorComponent (putWord8 0) + where elemCount = 2 ^ size + missingColorComponent = (elemCount - imageWidth pal) * 3 + +-------------------------------------------------- +---- GifImage +-------------------------------------------------- +data GifHeader = GifHeader + { gifVersion :: GifVersion + , gifScreenDescriptor :: LogicalScreenDescriptor + , gifGlobalMap :: !Palette + } + +instance Binary GifHeader where + put v = do + put $ gifVersion v + let descr = gifScreenDescriptor v + put $ descr + putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v + + get = do + version <- get + screenDesc <- get + palette <- getPalette $ colorTableSize screenDesc + return GifHeader + { gifVersion = version + , gifScreenDescriptor = screenDesc + , gifGlobalMap = palette + } + +data GifFile = GifFile + { gifHeader :: !GifHeader + , gifImages :: [(Maybe GraphicControlExtension, GifImage)] + , gifLoopingBehaviour :: GifLooping + } + +putLooping :: GifLooping -> Put +putLooping LoopingNever = return () +putLooping LoopingForever = putLooping $ LoopingRepeat 0 +putLooping (LoopingRepeat count) = do + putWord8 extensionIntroducer + putWord8 applicationLabel + putWord8 11 -- the size + putByteString $ BC.pack "NETSCAPE2.0" + putWord8 3 -- size of sub block + putWord8 1 + putWord16le count + putWord8 0 + +associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] +associateDescr [] = [] +associateDescr [BlockGraphicControl _] = [] +associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = + associateDescr rest +associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs +associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = + (Just ctrl, img) : associateDescr xs + +instance Binary GifFile where + put v = do + put $ gifHeader v + let putter (Nothing, i) = put i + putter (Just a, i) = put a >> put i + putLooping $ gifLoopingBehaviour v + mapM_ putter $ gifImages v + put gifTrailer + + get = do + hdr <- get + blocks <- parseGifBlocks + return GifFile { gifHeader = hdr + , gifImages = associateDescr blocks + , gifLoopingBehaviour = LoopingNever + } + +substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 +substituteColors palette = pixelMap swaper + where swaper n = pixelAt palette (fromIntegral n) 0 + +decodeImage :: GifImage -> Image Pixel8 +decodeImage img = runST $ runBoolReader $ do + outputVector <- lift . M.new $ width * height + decodeLzw (imgData img) 12 lzwRoot outputVector + frozenData <- lift $ V.unsafeFreeze outputVector + return . deinterlaceGif $ Image + { imageWidth = width + , imageHeight = height + , imageData = frozenData + } + where lzwRoot = fromIntegral $ imgLzwRootSize img + width = fromIntegral $ gDescImageWidth descriptor + height = fromIntegral $ gDescImageHeight descriptor + isInterlaced = gDescIsInterlaced descriptor + descriptor = imgDescriptor img + + deinterlaceGif | not isInterlaced = id + | otherwise = deinterlaceGifImage + +deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 +deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h + where lineIndices = gifInterlacingIndices h + generator x y = pixelAt img x y' + where y' = lineIndices V.! y + +gifInterlacingIndices :: Int -> V.Vector Int +gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices + where indices = flip zip [0..] $ + concat [ [0, 8 .. height - 1] + , [4, 4 + 8 .. height - 1] + , [2, 2 + 4 .. height - 1] + , [1, 1 + 2 .. height - 1] + ] + +paletteOf :: Palette -> GifImage -> Palette +paletteOf global GifImage { imgLocalPalette = Nothing } = global +paletteOf _ GifImage { imgLocalPalette = Just p } = p + +decodeAllGifImages :: GifFile -> [Image PixelRGB8] +decodeAllGifImages GifFile { gifImages = [] } = [] +decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette + , gifScreenDescriptor = wholeDescriptor + } + , gifImages = (_, firstImage) : rest } = map paletteApplyer $ + scanl generator (paletteOf palette firstImage, decodeImage firstImage) rest + where globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor + + {-background = backgroundIndex wholeDescriptor-} + + paletteApplyer (pal, img) = substituteColors pal img + + generator (_, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (paletteOf palette img2, generateImage pixeler globalWidth globalHeight) + where localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor + + left = fromIntegral $ gDescPixelsFromLeft descriptor + top = fromIntegral $ gDescPixelsFromTop descriptor + + isPixelInLocalImage x y = + x >= left && x < left + localWidth && y >= top && y < top + localHeight + + decoded = decodeImage img2 + + transparent :: Int + transparent = case controlExt of + Nothing -> 300 + Just ext -> if gceTransparentFlag ext + then fromIntegral $ gceTransparentColorIndex ext + else 300 + + pixeler x y + | isPixelInLocalImage x y && fromIntegral val /= transparent = val + where val = pixelAt decoded (x - left) (y - top) + pixeler x y = pixelAt img1 x y + +decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) +decodeFirstGifImage + GifFile { gifHeader = GifHeader { gifGlobalMap = palette} + , gifImages = ((_, gif):_) } = Right . substituteColors palette $ decodeImage gif +decodeFirstGifImage _ = Left "No image in gif file" + +-- | Transform a raw gif image to an image, witout +-- modifying the pixels. +-- This function can output the following pixel types : +-- +-- * PixelRGB8 +-- +decodeGif :: B.ByteString -> Either String DynamicImage +decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage) + +-- | Transform a raw gif to a list of images, representing +-- all the images of an animation. +decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] +decodeGifImages img = decodeAllGifImages <$> decode img + +-- | Default palette to produce greyscale images. +greyPalette :: Palette +greyPalette = generateImage toGrey 256 1 + where toGrey x _ = PixelRGB8 ix ix ix + where ix = fromIntegral x + +checkGifImageSizes :: [(a, b, Image px)] -> Bool +checkGifImageSizes [] = False +checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest + where width = imageWidth img + height = imageHeight img + + checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = + w == width && h == height + +checkPaletteValidity :: [(Palette, a, b)] -> Bool +checkPaletteValidity [] = False +checkPaletteValidity lst = + and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst + , let w = imageWidth p + h = imageHeight p ] + +areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool +areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img + where paletteElemCount = imageWidth palette + isTooBig v = fromIntegral v >= paletteElemCount + +computeMinimumLzwKeySize :: Palette -> Int +computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 + where go k | 2 ^ k >= itemCount = k + | otherwise = go $ k + 1 + +-- | Encode a gif animation to a bytestring. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String L.ByteString +encodeGifImages _ [] = Left "No image in list" +encodeGifImages _ imageList + | not $ checkGifImageSizes imageList = Left "Gif images have different size" + | not $ checkPaletteValidity imageList = + Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] + | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile + where + allFile = GifFile + { gifHeader = GifHeader + { gifVersion = GIF89a + , gifScreenDescriptor = logicalScreen + , gifGlobalMap = firstPalette + } + , gifImages = toSerialize + , gifLoopingBehaviour = looping + } + + logicalScreen = LogicalScreenDescriptor + { screenWidth = fromIntegral $ imageWidth firstImage + , screenHeight = fromIntegral $ imageHeight firstImage + , backgroundIndex = 0 + , hasGlobalMap = True + , colorResolution = 8 + , isColorTableSorted = False + , colorTableSize = 8 + } + + paletteEqual p = imageData firstPalette == imageData p + + controlExtension 0 = Nothing + controlExtension delay = Just GraphicControlExtension + { gceDisposalMethod = 0 + , gceUserInputFlag = False + , gceTransparentFlag = False + , gceDelay = fromIntegral delay + , gceTransparentColorIndex = 0 + } + + toSerialize = [(controlExtension delay, GifImage + { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img + , imgLocalPalette = Just palette + , imgLzwRootSize = fromIntegral $ lzwKeySize + , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img + }) | (palette, delay, img) <- imageList + , let lzwKeySize = computeMinimumLzwKeySize palette + ] + + imageDescriptor paletteSize palEqual img = ImageDescriptor + { gDescPixelsFromLeft = 0 + , gDescPixelsFromTop = 0 + , gDescImageWidth = fromIntegral $ imageWidth img + , gDescImageHeight = fromIntegral $ imageHeight img + , gDescHasLocalMap = paletteSize > 0 && not palEqual + , gDescIsInterlaced = False + , gDescIsImgDescriptorSorted = False + , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize + } + +-- | Encode a greyscale image to a bytestring. +encodeGifImage :: Image Pixel8 -> L.ByteString +encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of + Left err -> error $ "Impossible:" ++ err + Right v -> v + +-- | Encode an image with a given palette. +-- Can return errors if the palette is ill-formed. +-- +-- * A palette must have between 1 and 256 colors +-- +encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString +encodeGifImageWithPalette img palette = + encodeGifImages LoopingNever [(palette, 0, img)] + +-- | Write a greyscale in a gif file on the disk. +writeGifImage :: FilePath -> Image Pixel8 -> IO () +writeGifImage file = L.writeFile file . encodeGifImage + +-- | Write a list of images as a gif animation in a file. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String (IO ()) +writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst + +-- | Write a gif image with a palette to a file. +-- +-- * A palette must have between 1 and 256 colors +-- +writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette + -> Either String (IO ()) +writeGifImageWithPalette file img palette = + L.writeFile file <$> encodeGifImageWithPalette img palette + diff --git a/src/Codec/Picture/Gif/LZW.hs b/src/Codec/Picture/Gif/LZW.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Gif/LZW.hs @@ -0,0 +1,189 @@ +module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where + +import Data.Word( Word8 ) +import Control.Applicative( (<$>) ) +import Control.Monad( when ) + +import Data.Bits( (.&.) ) + +import Control.Monad.ST( ST ) +import Control.Monad.Trans.Class( MonadTrans, lift ) + +import Foreign.Storable ( Storable ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a +(.!!!.) = M.unsafeRead + {-M.read-} + +{-# INLINE (..!!!..) #-} +(..!!!..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> t (ST s) a +(..!!!..) v idx = lift $ v .!!!. idx + +{-# INLINE (.<-.) #-} +(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () +(.<-.) = M.unsafeWrite + {-M.write-} + +{-# INLINE (..<-..) #-} +(..<-..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> a -> t (ST s) () +(..<-..) v idx = lift . (v .<-. idx) + + +duplicateData :: (Show a, MonadTrans t, Storable a) + => M.STVector s a -> M.STVector s a + -> Int -> Int -> Int -> t (ST s) () +duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex + where endIndex = sourceIndex + size + aux i _ | i == endIndex = return () + aux i j = do + src .!!!. i >>= (dest .<-. j) + aux (i + 1) (j + 1) + +rangeSetter :: (Storable a, Num a) + => Int -> M.STVector s a + -> ST s (M.STVector s a) +rangeSetter count vec = aux 0 + where aux n | n == count = return vec + aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) + +decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +decodeLzw str maxBitKey initialKey outVec = do + setDecodedString str + lzw GifVariant maxBitKey initialKey 0 outVec + +isOldTiffLZW :: B.ByteString -> Bool +isOldTiffLZW str = firstByte == 0 && secondByte == 1 + where firstByte = str `B.index` 0 + secondByte = (str `B.index` 1) .&. 1 + +decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int + -> BoolReader s() +decodeLzwTiff str outVec initialWriteIdx = do + setDecodedString str + let variant | isOldTiffLZW str = OldTiffVariant + | otherwise = TiffVariant + lzw variant 12 9 initialWriteIdx outVec + +data TiffVariant = + GifVariant + | TiffVariant + | OldTiffVariant + deriving Eq + +-- | Gif image constraint from spec-gif89a, code size max : 12 bits. +lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do + -- Allocate buffer of maximum size. + lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray + lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray + lzwSizeTable <- lift $ M.replicate tableEntryCount 0 + lift $ lzwSizeTable `M.set` 1 + + let firstVal code = do + dataOffset <- lzwOffsetTable ..!!!.. code + lzwData ..!!!.. dataOffset + + writeString at code = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (at + dataSize <= maxWrite) $ + duplicateData lzwData outVec dataOffset dataSize at + + return dataSize + + addString pos at code val = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (pos < tableEntryCount) $ do + (lzwOffsetTable ..<-.. pos) at + (lzwSizeTable ..<-.. pos) $ dataSize + 1 + + when (at + dataSize + 1 <= maxDataSize) $ do + duplicateData lzwData lzwData dataOffset dataSize at + (lzwData ..<-.. (at + dataSize)) val + + return $ dataSize + 1 + + maxWrite = M.length outVec + loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code + | outWriteIdx >= maxWrite = return () + | code == endOfInfo = return () + | code == clearCode = do + toOutput <- getNextCode startCodeSize + if toOutput == endOfInfo then + return () + else do + dataSize <- writeString outWriteIdx toOutput + getNextCode startCodeSize >>= + loop (outWriteIdx + dataSize) + firstFreeIndex firstFreeIndex startCodeSize toOutput + + | otherwise = do + (written, dicAdd) <- + if code >= writeIdx then do + c <- firstVal oldCode + wroteSize <- writeString outWriteIdx oldCode + (outVec ..<-.. (outWriteIdx + wroteSize)) c + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize + 1, addedSize) + else do + wroteSize <- writeString outWriteIdx code + c <- firstVal code + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize, addedSize) + + let new_code_size = updateCodeSize codeSize $ writeIdx + 1 + getNextCode new_code_size >>= + loop (outWriteIdx + written) + (writeIdx + 1) + (dicWriteIdx + dicAdd) + new_code_size + code + + getNextCode startCodeSize >>= + loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 + + where tableEntryCount = 2 ^ min 12 nMaxBitKeySize + maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 + + isNewTiff = variant == TiffVariant + (switchOffset, isTiffVariant) = case variant of + GifVariant -> (0, False) + TiffVariant -> (1, True) + OldTiffVariant -> (0, True) + + initialElementCount = 2 ^ initialKeySize :: Int + clearCode | isTiffVariant = 256 + | otherwise = initialElementCount + + endOfInfo | isTiffVariant = 257 + | otherwise = clearCode + 1 + + startCodeSize + | isTiffVariant = initialKeySize + | otherwise = initialKeySize + 1 + + firstFreeIndex = endOfInfo + 1 + + resetArray a = lift $ rangeSetter initialElementCount a + + updateCodeSize codeSize writeIdx + | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 + | otherwise = codeSize + + getNextCode s + | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s + | otherwise = fromIntegral <$> getNextBitsLSBFirst s + diff --git a/src/Codec/Picture/Gif/LZWEncoding.hs b/src/Codec/Picture/Gif/LZWEncoding.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Gif/LZWEncoding.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE BangPatterns #-} +module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where + +import Control.Applicative( (<$>) ) +import Control.Monad.ST( runST ) +import qualified Data.ByteString.Lazy as L +import Data.Maybe( fromMaybe ) +import Data.Monoid( mempty ) +import Data.Word( Word8 ) +import qualified Data.IntMap.Strict as I +import qualified Data.Vector.Storable as V + +import Codec.Picture.BitWriter + +type Trie = I.IntMap TrieNode + +data TrieNode = TrieNode + { trieIndex :: {-# UNPACK #-} !Int + , trieSub :: !Trie + } + +emptyNode :: TrieNode +emptyNode = TrieNode + { trieIndex = -1 + , trieSub = mempty + } + +initialTrie :: Trie +initialTrie = I.fromList + [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] + +lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) +lookupUpdate vector freeIndex firstIndex trie = + matchUpdate $ go trie 0 firstIndex + where + matchUpdate (lzwOutputIndex, nextReadIndex, sub) = + (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) + + maxi = V.length vector + go !currentTrie !prevIndex !index + | index >= maxi = (prevIndex, index, Nothing) + | otherwise = case I.lookup val currentTrie of + Just (TrieNode ix subTable) -> + let (lzwOutputIndex, nextReadIndex, newTable) = + go subTable ix $ index + 1 + tableUpdater t = + I.insert val (TrieNode ix t) currentTrie + in + (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) + + Nothing | index == maxi -> (prevIndex, index, Nothing) + | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) + + where val = fromIntegral $ vector `V.unsafeIndex` index + newNode = emptyNode { trieIndex = freeIndex } + +lzwEncode :: Int -> V.Vector Word8 -> L.ByteString +lzwEncode initialKeySize vec = runST $ do + bitWriter <- newWriteStateRef + + let updateCodeSize 12 writeIdx _ + | writeIdx == 2 ^ (12 :: Int) - 1 = do + writeBitsGif bitWriter (fromIntegral clearCode) 12 + return (startCodeSize, firstFreeIndex, initialTrie) + + updateCodeSize codeSize writeIdx trie + | writeIdx == 2 ^ codeSize = + return (codeSize + 1, writeIdx + 1, trie) + | otherwise = return (codeSize, writeIdx + 1, trie) + + go readIndex (codeSize, _, _) | readIndex >= maxi = + writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize + go !readIndex (!codeSize, !writeIndex, !trie) = do + let (indexToWrite, endIndex, trie') = + lookuper writeIndex readIndex trie + writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize + updateCodeSize codeSize writeIndex trie' + >>= go endIndex + + writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize + go 0 (startCodeSize, firstFreeIndex, initialTrie) + + finalizeBoolWriter bitWriter + where + maxi = V.length vec + + startCodeSize = initialKeySize + 1 + + clearCode = 2 ^ initialKeySize :: Int + endOfInfo = clearCode + 1 + firstFreeIndex = endOfInfo + 1 + + lookuper = lookupUpdate vec diff --git a/src/Codec/Picture/HDR.hs b/src/Codec/Picture/HDR.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/HDR.hs @@ -0,0 +1,462 @@ +-- | Module dedicated of Radiance file decompression (.hdr or .pic) file. +-- Radiance file format is used for High dynamic range imaging. +module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where + +import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.Char( ord, chr, isDigit ) +import Data.Word( Word8 ) +import Data.Monoid( (<>) ) +import Control.Applicative( pure, (<$>), (<*>) ) +import Control.Monad( when, foldM, foldM_, forM, forM_ ) +import Control.Monad.Trans.Class( lift ) +import Control.Monad.Trans.Error( ErrorT, throwError, runErrorT ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as BC + +import Data.List( partition ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get, getByteString, getWord8 ) +import Data.Binary.Put( putByteString, putLazyByteString ) + +import Control.Monad.ST( ST, runST ) +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 Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.VectorByteConversion + +{-# INLINE (.<<.) #-} +(.<<.), (.>>.) :: (Bits a) => a -> Int -> a +(.<<.) = unsafeShiftL +(.>>.) = unsafeShiftR + +{-# INLINE (.<-.) #-} +(.<-.) :: (PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> a -> m () +(.<-.) = M.write + {-M.unsafeWrite-} + +type HDRReader s a = ErrorT String (ST s) a + +data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 + +instance Binary RGBE where + put (RGBE r g b e) = put r >> put g >> put b >> put e + get = RGBE <$> get <*> get <*> get <*> get + +checkLineLength :: RGBE -> Int +checkLineLength (RGBE _ _ a b) = + (fromIntegral a .<<. 8) .|. fromIntegral b + +isNewRunLengthMarker :: RGBE -> Bool +isNewRunLengthMarker (RGBE 2 2 _ _) = True +isNewRunLengthMarker _ = False + +data RadianceFormat = + FormatRGBE + | FormatXYZE + +radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString +radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" +radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" + +instance Binary RadianceFormat where + put FormatRGBE = putByteString radiance32bitRleRGBEFormat + put FormatXYZE = putByteString radiance32bitRleXYZEFromat + + get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format + where format sig + | sig == radiance32bitRleRGBEFormat = pure FormatRGBE + | sig == radiance32bitRleXYZEFromat = pure FormatXYZE + | otherwise = fail "Unrecognized Radiance format" + +toRGBE :: PixelRGBF -> RGBE +toRGBE (PixelRGBF r g b) + | d <= 1e-32 = RGBE 0 0 0 0 + | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) + where d = maximum [r, g, b] + e = exponent d + coeff = significand d * 255.9999 / d + fix v = truncate $ v * coeff + + +dropUntil :: Word8 -> Get () +dropUntil c = getWord8 >>= inner + where inner val | val == c = pure () + inner _ = getWord8 >>= inner + +getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString +getUntil f initialAcc = getWord8 >>= inner initialAcc + where inner acc c | f c = pure acc + inner acc c = getWord8 >>= inner (B.snoc acc c) + +data RadianceHeader = RadianceHeader + { radianceInfos :: [(B.ByteString, B.ByteString)] + , radianceFormat :: RadianceFormat + , radianceHeight :: !Int + , radianceWidth :: !Int + , radianceData :: L.ByteString + } + +radianceFileSignature :: B.ByteString +radianceFileSignature = BC.pack "#?RADIANCE\n" + +unpackColor :: L.ByteString -> Int -> RGBE +unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) + where at n = L.index str . fromIntegral $ idx + n + +storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () +storeColor vec idx (RGBE r g b e) = do + (vec .<-. (idx + 0)) r + (vec .<-. (idx + 1)) g + (vec .<-. (idx + 2)) b + (vec .<-. (idx + 3)) e + +parsePair :: Char -> Get (B.ByteString, B.ByteString) +parsePair firstChar = do + let eol c = c == fromIntegral (ord '\n') + line <- getUntil eol B.empty + case BC.split '=' line of + [] -> pure (BC.singleton firstChar, B.empty) + [val] -> pure (BC.singleton firstChar, val) + [key, val] -> pure (BC.singleton firstChar <> key, val) + (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) + +decodeInfos :: Get [(B.ByteString, B.ByteString)] +decodeInfos = do + char <- getChar8 + case char of + -- comment + '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos + -- end of header, no more information + '\n' -> pure [] + -- Classical parsing + c -> (:) <$> parsePair c <*> decodeInfos + + +-- | Decode an HDR (radiance) image, the resulting pixel +-- type can be : +-- +-- * PixelRGBF +-- +decodeHDR :: B.ByteString -> Either String DynamicImage +decodeHDR str = runST $ runErrorT $ do + case runGet decodeHeader $ L.fromChunks [str] of + Left err -> throwError err + Right rez -> + ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) + +getChar8 :: Get Char +getChar8 = chr . fromIntegral <$> getWord8 + +isSign :: Char -> Bool +isSign c = c == '+' || c == '-' + +isAxisLetter :: Char -> Bool +isAxisLetter c = c == 'X' || c == 'Y' + +decodeNum :: Get Int +decodeNum = do + sign <- getChar8 + letter <- getChar8 + space <- getChar8 + + when (not $ isSign sign && isAxisLetter letter && space == ' ') + (fail "Invalid radiance size declaration") + + let numDec acc c | isDigit c = + getChar8 >>= numDec (acc * 10 + ord c - (ord '0')) + numDec acc _ + | sign == '-' = pure $ negate acc + | otherwise = pure acc + + getChar8 >>= numDec 0 + +copyPrevColor :: M.STVector s Word8 -> Int -> ST s () +copyPrevColor scanLine idx = do + r <- scanLine `M.unsafeRead` (idx - 4) + g <- scanLine `M.unsafeRead` (idx - 3) + b <- scanLine `M.unsafeRead` (idx - 2) + e <- scanLine `M.unsafeRead` (idx - 1) + + (scanLine `M.unsafeWrite` (idx + 0)) r + (scanLine `M.unsafeWrite` (idx + 1)) g + (scanLine `M.unsafeWrite` (idx + 2)) b + (scanLine `M.unsafeWrite` (idx + 3)) e + +oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 + where maxOutput = M.length scanLine + maxInput = fromIntegral $ L.length inputData + + inner readIdx writeIdx _ + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx shift = do + let color@(RGBE r g b e) = unpackColor inputData readIdx + isRun = r == 1 && g == 1 && b == 1 + + if not isRun + then do + lift $ storeColor scanLine writeIdx color + inner (readIdx + 4) (writeIdx + 4) 0 + + else do + let count = fromIntegral e .<<. shift + lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) + inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) + +newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] + where dataAt idx + | fromIntegral idx >= maxInput = throwError $ "Read index out of bound (" ++ show idx ++ ")" + | otherwise = pure $ L.index inputData (fromIntegral idx) + + maxOutput = M.length scanline + maxInput = fromIntegral $ L.length inputData + stride = 4 + + + strideSet count destIndex _ | endIndex > maxOutput + stride = + throwError $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" + where endIndex = destIndex + count * stride + strideSet count destIndex val = aux destIndex count + where aux i 0 = pure i + aux i c = do + lift $ (scanline .<-. i) val + aux (i + stride) (c - 1) + + + strideCopy _ count destIndex + | writeEndBound > maxOutput + stride = throwError "Out of bound HDR scanline" + where writeEndBound = destIndex + count * stride + strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count + where aux _ j 0 = pure j + aux i j c = do + val <- dataAt i + lift $ (scanline .<-. j) val + aux (i + 1) (j + stride) (c - 1) + + inner readIdx writeIdx + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx = do + code <- dataAt readIdx + if code > 128 + then do + let repeatCount = fromIntegral code .&. 0x7F + newVal <- dataAt $ readIdx + 1 + endIndex <- strideSet repeatCount writeIdx newVal + inner (readIdx + 2) endIndex + + else do + let iCode = fromIntegral code + endIndex <- strideCopy (readIdx + 1) iCode writeIdx + inner (readIdx + iCode + 1) endIndex + +instance Binary RadianceHeader where + get = decodeHeader + put hdr = do + putByteString radianceFileSignature + putByteString $ BC.pack "FORMAT=" + put $ radianceFormat hdr + let sizeString = + BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) + ++ " +X " ++ show (radianceWidth hdr) ++ "\n" + putByteString sizeString + putLazyByteString $ radianceData hdr + + +decodeHeader :: Get RadianceHeader +decodeHeader = do + sig <- getByteString $ B.length radianceFileSignature + when (sig /= radianceFileSignature) + (fail "Invalid radiance file signature") + + infos <- decodeInfos + let formatKey = BC.pack "FORMAT" + case partition (\(k,_) -> k /= formatKey) infos of + (_, []) -> fail "No radiance format specified" + (info, [(_, formatString)]) -> + case runGet get $ L.fromChunks [formatString] of + Left err -> fail err + Right format -> do + (n1, n2, b) <- (,,) <$> decodeNum + <*> decodeNum + <*> getRemainingBytes + return . RadianceHeader info format n1 n2 $ L.fromChunks [b] + + _ -> fail "Multiple radiance format specified" + +toFloat :: RGBE -> PixelRGBF +toFloat (RGBE r g b e) = PixelRGBF rf gf bf + where f = encodeFloat 1 $ fromIntegral e - (128 + 8) + rf = (fromIntegral r + 0.0) * f + gf = (fromIntegral g + 0.0) * f + bf = (fromIntegral b + 0.0) * f + +encodeScanlineColor :: M.STVector s Word8 + -> M.STVector s Word8 + -> Int + -> ST s Int +encodeScanlineColor vec outVec outIdx = do + val <- vec `M.unsafeRead` 0 + runLength 1 0 val 1 outIdx + where maxIndex = M.length vec + + pushRun len val at = do + (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 + (outVec `M.unsafeWrite` (at + 1)) val + return $ at + 2 + + pushData start len at = do + (outVec `M.unsafeWrite` at) $ fromIntegral len + let first = start - len + end = start - 1 + offset = at - first + 1 + forM_ [first .. end] $ \i -> do + v <- vec `M.unsafeRead` i + (outVec `M.unsafeWrite` (offset + i)) v + + return $ at + len + 1 + + -- End of scanline, empty the thing + runLength run cpy prev idx at | idx >= maxIndex = + case (run, cpy) of + (0, 0) -> pure at + (0, n) -> pushData idx n at + (n, 0) -> pushRun n prev at + (_, _) -> error "HDR - Run length algorithm is wrong" + + -- full runlength, we must write the packet + runLength r@127 _ prev idx at = do + val <- vec `M.unsafeRead` idx + pushRun r prev at >>= + runLength 1 0 val (idx + 1) + + -- full copy, we must write the packet + runLength _ c@127 _ idx at = do + val <- vec `M.unsafeRead` idx + pushData idx c at >>= + runLength 1 0 val (idx + 1) + + runLength n 0 prev idx at = do + val <- vec `M.unsafeRead` idx + case val == prev of + True -> runLength (n + 1) 0 prev (idx + 1) at + False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at + False -> do + pushRun n prev at >>= + runLength 1 0 val (idx + 1) + + runLength 0 n prev idx at = do + val <- vec `M.unsafeRead` idx + if val /= prev + then runLength 0 (n + 1) val (idx + 1) at + else do + pushData (idx - 1) (n - 1) at >>= + runLength (2 :: Int) 0 val (idx + 1) + + runLength _ _ _ _ _ = + error "HDR RLE inconsistent state" + +-- | Write an High dynamic range image into a radiance +-- image file on disk. +writeHDR :: FilePath -> Image PixelRGBF -> IO () +writeHDR filename img = L.writeFile filename $ encodeHDR img + +-- | Encode an High dynamic range image into a radiance image +-- file format. +encodeHDR :: Image PixelRGBF -> L.ByteString +encodeHDR pic = encode $ runST $ do + let w = imageWidth pic + h = imageHeight pic + + scanLineR <- M.new w :: ST s (M.STVector s Word8) + scanLineG <- M.new w + scanLineB <- M.new w + scanLineE <- M.new w + + encoded <- + forM [0 .. h - 1] $ \line -> do + buff <- M.new $ w * 4 + w `div` 127 + 2 + let columner col | col >= w = return () + columner col = do + let RGBE r g b e = toRGBE $ pixelAt pic col line + (scanLineR `M.unsafeWrite` col) r + (scanLineG `M.unsafeWrite` col) g + (scanLineB `M.unsafeWrite` col) b + (scanLineE `M.unsafeWrite` col) e + + columner (col + 1) + + columner 0 + + (buff `M.unsafeWrite` 0) 2 + (buff `M.unsafeWrite` 1) 2 + (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) + (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) + + i1 <- encodeScanlineColor scanLineR buff 4 + i2 <- encodeScanlineColor scanLineG buff i1 + i3 <- encodeScanlineColor scanLineB buff i2 + endIndex <- encodeScanlineColor scanLineE buff i3 + + (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff + + pure $ RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = h + , radianceWidth = w + , radianceData = L.fromChunks encoded + } + + +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF)) +decodeRadiancePicture hdr = do + let width = abs $ radianceWidth hdr + height = abs $ radianceHeight hdr + packedData = radianceData hdr + + scanLine <- lift $ M.new $ width * 4 + resultBuffer <- lift $ M.new $ width * height * 3 + + let scanLineImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = 1 + , mutableImageData = scanLine + } + + finalImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = height + , mutableImageData = resultBuffer + } + + let scanLineExtractor readIdx line = do + let color = unpackColor packedData readIdx + inner | isNewRunLengthMarker color = do + let calcSize = checkLineLength color + when (calcSize /= width) + (throwError "Invalid sanline size") + pure $ \idx -> newStyleRLE packedData (idx + 4) + | otherwise = pure $ oldStyleRLE packedData + f <- inner + newRead <- f readIdx scanLine + forM_ [0 .. width - 1] $ \i -> do + -- mokay, it's a hack, but I don't want to define a + -- pixel instance of RGBE... + PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 + lift $ writePixel finalImage i line . toFloat $ RGBE r g b e + + return newRead + + foldM_ scanLineExtractor 0 [0 .. height - 1] + + return finalImage + diff --git a/src/Codec/Picture/InternalHelper.hs b/src/Codec/Picture/InternalHelper.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/InternalHelper.hs @@ -0,0 +1,33 @@ +module Codec.Picture.InternalHelper ( runGet + , runGetStrict + , decode + , getRemainingBytes + , getRemainingLazyBytes ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Binary( Binary( get ) ) +import Data.Binary.Get( Get, runGetOrFail, getRemainingLazyByteString ) + +decode :: (Binary a) => B.ByteString -> Either String a +decode = runGetStrict get + +runGet :: Get a -> L.ByteString -> Either String a +runGet act = unpack . runGetOrFail act + where unpack (Left (_, _, str)) = Left str + unpack (Right (_, _, element)) = Right element + +runGetStrict :: Get a -> B.ByteString -> Either String a +runGetStrict act buffer = runGet act $ L.fromChunks [buffer] + +getRemainingBytes :: Get B.ByteString +getRemainingBytes = do + rest <- getRemainingLazyByteString + return $ case L.toChunks rest of + [] -> B.empty + [a] -> a + lst -> B.concat lst + +getRemainingLazyBytes :: Get L.ByteString +getRemainingLazyBytes = getRemainingLazyByteString + diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg.hs @@ -0,0 +1,721 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS_GHC -fspec-constr-count=5 #-} +-- | Module used for JPEG file loading and writing. +module Codec.Picture.Jpg( decodeJpeg + , encodeJpegAtQuality + , encodeJpeg + + , jpgMachineStep + ) where + +import Control.Arrow( (>>>) ) +import Control.Applicative( pure, (<$>) ) +import Control.Monad( when, forM_ ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.Trans( lift ) +import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS ) + +import Data.Bits( (.|.), unsafeShiftL ) +import Data.Int( Int16, Int32 ) +import Data.Word(Word8, Word32) +import Data.Binary( Binary(..), encode ) +import Data.STRef( newSTRef, writeSTRef, readSTRef ) + +import Data.Vector( (//) ) +import Data.Vector.Unboxed( (!) ) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Codec.Picture.InternalHelper +import Codec.Picture.BitWriter +import Codec.Picture.Types +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.Common +import Codec.Picture.Jpg.Progressive +import Codec.Picture.Jpg.DefaultTable +import Codec.Picture.Jpg.FastDct + +quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 + -> ST s (MutableMacroBlock s Int32) +quantize table block = update 0 + where update 64 = return block + update idx = do + val <- block `M.unsafeRead` idx + let q = fromIntegral (table `VS.unsafeIndex` idx) + finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division + (block `M.unsafeWrite` idx) finalValue + update $ idx + 1 + + +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 :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s () +{-# INLINE encodeInt #-} +encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss) +encodeInt st ssss n = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss) + +-- | Assume the macro block is initialized with zeroes +acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16 + -> BoolReader s (MutableMacroBlock s Int16) +acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock + where parseAcCoefficient n | n >= 64 = return () + | otherwise = do + rrrrssss <- decodeRrrrSsss acTree + case rrrrssss of + ( 0, 0) -> return () + (0xF, 0) -> parseAcCoefficient (n + 16) + (rrrr, ssss) -> do + decoded <- fromIntegral <$> decodeInt ssss + lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded + parseAcCoefficient (n + rrrr + 1) + +-- | Decompress a macroblock from a bitstream given the current configuration +-- from the frame. +decompressMacroBlock :: HuffmanPackedTree -- ^ Tree used for DC coefficient + -> HuffmanPackedTree -- ^ Tree used for Ac coefficient + -> MacroBlock Int16 -- ^ Current quantization table + -> MutableMacroBlock s Int16 -- ^ A zigzag table, to avoid allocation + -> DcCoefficient -- ^ Previous dc value + -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16) +decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do + dcDeltaCoefficient <- dcCoefficientDecode dcTree + block <- lift createEmptyMutableMacroBlock + let neoDcCoefficient = previousDc + dcDeltaCoefficient + lift $ (block `M.unsafeWrite` 0) neoDcCoefficient + fullBlock <- acCoefficientsDecode acTree block + decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock + return (neoDcCoefficient, decodedBlock) + +pixelClamp :: Int16 -> Word8 +pixelClamp n = fromIntegral . min 255 $ max 0 n + +unpack444Y :: Int -- ^ component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpack444Y _ x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) + block = blockVert baseIdx 0 zero + where zero = 0 :: Int + baseIdx = x * dctBlockSize + y * dctBlockSize * imgWidth + + blockVert _ _ j | j >= dctBlockSize = return () + blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero + where blockHoriz _ readIdx i | i >= dctBlockSize = blockVert (writeIdx + imgWidth) readIdx $ j + 1 + blockHoriz idx readIdx i = do + val <- pixelClamp <$> (block `M.unsafeRead` readIdx) + (img `M.unsafeWrite` idx) val + blockHoriz (idx + 1) (readIdx + 1) $ i + 1 + +unpack444Ycbcr :: Int -- ^ Component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpack444Ycbcr compIdx x y + (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) + block = blockVert baseIdx 0 zero + where zero = 0 :: Int + baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx + + blockVert _ _ j | j >= dctBlockSize = return () + blockVert idx readIdx j = do + val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) + val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) + val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) + val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) + val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) + val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) + val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) + val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) + + (img `M.unsafeWrite` idx) val0 + (img `M.unsafeWrite` (idx + (3 * 1))) val1 + (img `M.unsafeWrite` (idx + (3 * 2))) val2 + (img `M.unsafeWrite` (idx + (3 * 3))) val3 + (img `M.unsafeWrite` (idx + (3 * 4))) val4 + (img `M.unsafeWrite` (idx + (3 * 5))) val5 + (img `M.unsafeWrite` (idx + (3 * 6))) val6 + (img `M.unsafeWrite` (idx + (3 * 7))) val7 + + blockVert (idx + 3 * imgWidth) (readIdx + dctBlockSize) $ j + 1 + + + {-where blockHoriz _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-} + {-blockHoriz idx readIdx i = do-} + {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -} + {-(img `M.unsafeWrite` idx) val-} + {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-} + +unpack421Ycbcr :: Int -- ^ Component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpack421Ycbcr compIdx x y + (MutableImage { mutableImageWidth = imgWidth, + mutableImageHeight = _, mutableImageData = img }) + block = blockVert baseIdx 0 zero + where zero = 0 :: Int + baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx + lineOffset = imgWidth * 3 + + blockVert _ _ j | j >= dctBlockSize = return () + blockVert idx readIdx j = do + v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) + v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) + v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) + v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) + v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) + v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) + v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) + v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) + + (img `M.unsafeWrite` idx) v0 + (img `M.unsafeWrite` (idx + 3)) v0 + + (img `M.unsafeWrite` (idx + 6 * 1)) v1 + (img `M.unsafeWrite` (idx + 6 * 1 + 3)) v1 + + (img `M.unsafeWrite` (idx + 6 * 2)) v2 + (img `M.unsafeWrite` (idx + 6 * 2 + 3)) v2 + + (img `M.unsafeWrite` (idx + 6 * 3)) v3 + (img `M.unsafeWrite` (idx + 6 * 3 + 3)) v3 + + (img `M.unsafeWrite` (idx + 6 * 4)) v4 + (img `M.unsafeWrite` (idx + 6 * 4 + 3)) v4 + + (img `M.unsafeWrite` (idx + 6 * 5)) v5 + (img `M.unsafeWrite` (idx + 6 * 5 + 3)) v5 + + (img `M.unsafeWrite` (idx + 6 * 6)) v6 + (img `M.unsafeWrite` (idx + 6 * 6 + 3)) v6 + + (img `M.unsafeWrite` (idx + 6 * 7)) v7 + (img `M.unsafeWrite` (idx + 6 * 7 + 3)) v7 + + blockVert (idx + lineOffset) (readIdx + dctBlockSize) $ j + 1 + +type Unpacker s = Int -- ^ component index + -> Int -- ^ x + -> Int -- ^ y + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () + +type JpgScripter s a = + RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a + +data JpgDecoderState = JpgDecoderState + { dcDecoderTables :: !(V.Vector HuffmanPackedTree) + , acDecoderTables :: !(V.Vector HuffmanPackedTree) + , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) + , currentRestartInterv :: !Int + , currentFrame :: Maybe JpgFrameHeader + , isProgressive :: !Bool + , maximumHorizontalResolution :: !Int + , maximumVerticalResolution :: !Int + , seenBlobs :: !Int + } + +emptyDecoderState :: JpgDecoderState +emptyDecoderState = JpgDecoderState + { dcDecoderTables = V.fromList $ map snd + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable + ] + + , acDecoderTables = V.fromList $ map snd + [ prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable + ] + + , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1) + , currentRestartInterv = -1 + , currentFrame = Nothing + , isProgressive = False + , maximumHorizontalResolution = 0 + , maximumVerticalResolution = 0 + , seenBlobs = 0 + } + +-- | This pseudo interpreter interpret the Jpg frame for the huffman, +-- quant table and restart interval parameters. +jpgMachineStep :: JpgFrame -> JpgScripter s () +jpgMachineStep (JpgAppFrame _ _) = pure () +jpgMachineStep (JpgExtension _ _) = pure () +jpgMachineStep (JpgScanBlob hdr raw_data) = do + let scanCount = length $ scans hdr + params <- concat <$> mapM (scanSpecifier scanCount) (scans hdr) + modify $ \st -> st { seenBlobs = seenBlobs st + 1 } + tell [(params, raw_data) ] + where (selectionLow, selectionHigh) = spectralSelection hdr + approxHigh = fromIntegral $ successiveApproxHigh hdr + approxLow = fromIntegral $ successiveApproxLow hdr + + scanSpecifier scanCount scanSpec = do + let dcIndex = fromIntegral $ dcEntropyCodingTable scanSpec + acIndex = fromIntegral $ acEntropyCodingTable scanSpec + comp = fromIntegral (componentSelector scanSpec) - 1 + dcTree <- gets $ (V.! dcIndex) . dcDecoderTables + acTree <- gets $ (V.! acIndex) . acDecoderTables + isProgressiveImage <- gets isProgressive + maxiW <- gets maximumHorizontalResolution + maxiH <- gets maximumVerticalResolution + restart <- gets currentRestartInterv + frameInfo <- gets currentFrame + blobId <- gets seenBlobs + case frameInfo of + Nothing -> fail "Jpg decoding error - no previous frame" + Just v -> do + let compDesc = jpgComponents v !! comp + compCount = length $ jpgComponents v + xSampling = fromIntegral $ horizontalSamplingFactor compDesc + ySampling = fromIntegral $ verticalSamplingFactor compDesc + componentSubSampling = + (maxiW - xSampling + 1, maxiH - ySampling + 1) + (xCount, yCount) + | scanCount > 1 || isProgressiveImage = (xSampling, ySampling) + | otherwise = (1, 1) + + pure [ (JpgUnpackerParameter + { dcHuffmanTree = dcTree + , acHuffmanTree = acTree + , componentIndex = comp + , restartInterval = fromIntegral restart + , componentWidth = xSampling + , componentHeight = ySampling + , subSampling = componentSubSampling + , successiveApprox = (approxLow, approxHigh) + , readerIndex = blobId + , indiceVector = + if scanCount == 1 then 0 else 1 + , coefficientRange = + ( fromIntegral selectionLow + , fromIntegral selectionHigh ) + , blockIndex = y * ySampling + x + , blockMcuX = x + , blockMcuY = y + }, unpackerDecision compCount componentSubSampling) + | y <- [0 .. yCount - 1] + , x <- [0 .. xCount - 1] ] + +jpgMachineStep (JpgScans kind hdr) = modify $ \s -> + s { currentFrame = Just hdr + , isProgressive = case kind of + JpgProgressiveDCTHuffman -> True + _ -> False + , maximumHorizontalResolution = + fromIntegral $ maximum horizontalResolutions + , maximumVerticalResolution = + fromIntegral $ maximum verticalResolutions + } + where components = jpgComponents hdr + horizontalResolutions = map horizontalSamplingFactor components + verticalResolutions = map verticalSamplingFactor components +jpgMachineStep (JpgIntervalRestart restart) = + modify $ \s -> s { currentRestartInterv = fromIntegral restart } +jpgMachineStep (JpgHuffmanTable tables) = mapM_ placeHuffmanTrees tables + where placeHuffmanTrees (spec, tree) = case huffmanTableClass spec of + DcComponent -> modify $ \s -> + let neu = dcDecoderTables s // [(idx, tree)] in + s { dcDecoderTables = neu `seq` neu } + where idx = fromIntegral $ huffmanTableDest spec + + AcComponent -> modify $ \s -> + s { acDecoderTables = acDecoderTables s // [(idx, tree)] } + where idx = fromIntegral $ huffmanTableDest spec + +jpgMachineStep (JpgQuantTable tables) = mapM_ placeQuantizationTables tables + where placeQuantizationTables table = do + let idx = fromIntegral $ quantDestination table + tableData = quantTable table + modify $ \s -> + s { quantizationMatrices = quantizationMatrices s // [(idx, tableData)] } + +unpackerDecision :: Int -> (Int, Int) -> Unpacker s +unpackerDecision 1 (1, 1) = unpack444Y +unpackerDecision _ (1, 1) = unpack444Ycbcr +unpackerDecision _ (2, 1) = unpack421Ycbcr +unpackerDecision compCount (xScalingFactor, yScalingFactor) = + unpackMacroBlock compCount xScalingFactor yScalingFactor + +decodeImage :: JpgFrameHeader + -> V.Vector (MacroBlock Int16) + -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] + -> MutableImage s PixelYCbCr8 -- ^ Result image to write into + -> ST s () +decodeImage frame quants lst outImage = do + let compCount = length $ jpgComponents frame + zigZagArray <- createEmptyMutableMacroBlock + dcArray <- M.replicate compCount 0 :: ST s (M.STVector s DcCoefficient) + resetCounter <- newSTRef restartIntervalValue + + forM_ lst $ \(params, str) -> do + let componentsInfo = V.fromList params + compReader = initBoolStateJpg . B.concat $ L.toChunks str + maxiW = maximum [fst $ subSampling c | (c,_) <- params] + maxiH = maximum [snd $ subSampling c | (c,_) <- params] + + imageBlockWidth = (imgWidth + 7) `div` 8 + imageBlockHeight = (imgHeight + 7) `div` 8 + + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW + imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH + + execBoolReader compReader $ rasterMap imageMcuWidth imageMcuHeight $ \x y -> do + resetLeft <- lift $ readSTRef resetCounter + if resetLeft == 0 then do + lift $ M.set dcArray 0 + byteAlignJpg + _restartCode <- decodeRestartInterval + lift $ resetCounter `writeSTRef` (restartIntervalValue - 1) + else + lift $ resetCounter `writeSTRef` (resetLeft - 1) + + V.forM_ componentsInfo $ \(comp, unpack) -> do + let compIdx = componentIndex comp + dcTree = dcHuffmanTree comp + acTree = acHuffmanTree comp + qTable = quants V.! (min 1 compIdx) + xd = blockMcuX comp + yd = blockMcuY comp + (subX, subY) = subSampling comp + dc <- lift $ dcArray `M.unsafeRead` compIdx + (dcCoeff, block) <- + decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc + lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff + let verticalLimited = y == imageMcuHeight - 1 + if (x == imageMcuWidth - 1) || verticalLimited then + lift $ unpackMacroBlock imgComponentCount + subX subY compIdx + (x * maxiW + xd) (y * maxiH + yd) outImage block + else + lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block + + where imgComponentCount = length $ jpgComponents frame + + imgWidth = fromIntegral $ jpgWidth frame + imgHeight = fromIntegral $ jpgHeight frame + restartIntervalValue = case lst of + ((p,_):_,_): _ -> restartInterval p + _ -> -1 + +gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind +gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of + [JpgBaselineDCTHuffman] -> Just BaseLineDCT + [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT + _ -> Nothing + where isDctSpecifier JpgProgressiveDCTHuffman = True + isDctSpecifier JpgBaselineDCTHuffman = True + isDctSpecifier _ = False + +gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) +gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img] + +-- | 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 'convertImage' from the 'ColorSpaceConvertible' +-- typeclass. +-- +-- This function can output the following pixel types : +-- +-- * PixelY8 +-- +-- * PixelYCbCr8 +-- +decodeJpeg :: B.ByteString -> Either String DynamicImage +decodeJpeg file = case runGetStrict get file of + Left err -> Left err + Right img -> case (compCount, imgKind) of + (_, Nothing) -> Left "Unknown Jpg kind" + (3, Just ProgressiveDCT) -> Right . ImageYCbCr8 $ decodeProgressive + (1, Just BaseLineDCT) -> Right . ImageY8 $ Image imgWidth imgHeight pixelData + (3, Just BaseLineDCT) -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData + _ -> Left "Wrong component count" + + where compCount = length $ jpgComponents scanInfo + (_,scanInfo) = gatherScanInfo img + + imgKind = gatherImageKind $ jpgFrame img + imgWidth = fromIntegral $ jpgWidth scanInfo + imgHeight = fromIntegral $ jpgHeight scanInfo + + imageSize = imgWidth * imgHeight * compCount + (st, wrotten) = execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState + Just fHdr = currentFrame st + + decodeProgressive = runST $ + progressiveUnpack + (maximumHorizontalResolution st, maximumVerticalResolution st) + fHdr + (quantizationMatrices st) + wrotten >>= unsafeFreezeImage + + pixelData = runST $ do + resultImage <- M.new imageSize + let wrapped = MutableImage imgWidth imgHeight resultImage + decodeImage + fHdr + (quantizationMatrices st) + wrotten + wrapped + VS.unsafeFreeze resultImage + +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 * dctBlockSize) + 7 < w && (by * 8) + 7 < h = do + let baseReadIdx = (by * dctBlockSize * w) + bx * dctBlockSize + sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) val + | y <- [0 .. dctBlockSize - 1] + , let blockReadIdx = baseReadIdx + y * w + , x <- [0 .. dctBlockSize - 1] + , let val = fromIntegral $ src `VS.unsafeIndex` ((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 `VS.unsafeIndex` 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 * dctBlockSize * sampWidth + blockYBegin = by * dctBlockSize * sampHeight + + sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ] + return block + +serializeMacroBlock :: BoolWriteStateRef s + -> HuffmanWriterCode -> HuffmanWriterCode + -> MutableMacroBlock s Int32 + -> ST s () +serializeMacroBlock !st !dcCode !acCode !blk = + (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return () + where writeAcs acc@(_, 63) = + (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return () + writeAcs acc@(_, i ) = + (blk `M.unsafeRead` i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs + + encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount) + >> when (ssss /= 0) (encodeInt st ssss n) + where ssss = powerOf $ fromIntegral n + (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss + + encodeAc 0 0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount + where (bitCount, code) = acCode `V.unsafeIndex` 0 + + encodeAc zeroCount n | zeroCount >= 16 = + writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeAc (zeroCount - 16) n + where (bitCount, code) = acCode `V.unsafeIndex` 0xF0 + encodeAc zeroCount n = + writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n + where rrrr = zeroCount `unsafeShiftL` 4 + ssss = powerOf $ fromIntegral n + rrrrssss = rrrr .|. ssss + (bitCount, code) = acCode `V.unsafeIndex` 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 `M.unsafeRead` 0 + (blk `M.unsafeWrite` 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, HuffmanPackedTree) +prepareHuffmanTable classVal dest tableDef = + (JpgHuffmanTableSpec { huffmanTableClass = classVal + , huffmanTableDest = dest + , huffSizes = sizes + , huffCodes = V.fromListN 16 + [VU.fromListN (fromIntegral $ sizes ! i) lst + | (i, lst) <- zip [0..] tableDef ] + }, VS.singleton 0) + where sizes = VU.fromListN 16 $ 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 -> L.ByteString +encodeJpeg = encodeJpegAtQuality 50 + +defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)] +defaultHuffmanTables = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable + , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable + ] + +-- | 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 + -> L.ByteString -- ^ Encoded JPEG +encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage + where finalImage = JpgImage [ JpgQuantTable quantTables + , JpgScans JpgBaselineDCTHuffman hdr + , JpgHuffmanTable defaultHuffmanTables + , JpgScanBlob scanHeader encodedImage + ] + + 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 $ do + let horizontalMetaBlockCount = + w `divUpward` (dctBlockSize * maxSampling) + verticalMetaBlockCount = + h `divUpward` (dctBlockSize * 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 + + dc_table <- M.replicate 3 0 + block <- createEmptyMutableMacroBlock + workData <- createEmptyMutableMacroBlock + zigzaged <- createEmptyMutableMacroBlock + writeState <- newWriteStateRef + + -- It's ugly, I know, be avoid allocation + let blockDecoder mx my = component $ zip [0..] componentDef + where component [] = return () + component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = + rasterMap sizeX sizeY decoder >> component comp_rest + where xSamplingFactor = maxSampling - sizeX + 1 + ySamplingFactor = maxSampling - sizeY + 1 + extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount + + decoder subX subY = do + let blockY = my * sizeY + subY + blockX = mx * sizeX + subX + prev_dc <- dc_table `M.unsafeRead` comp + (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= + encodeMacroBlock table workData zigzaged prev_dc) + (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff + serializeMacroBlock writeState dc ac neo_block + + rasterMap + horizontalMetaBlockCount verticalMetaBlockCount + blockDecoder + + finalizeBoolWriter writeState + diff --git a/src/Codec/Picture/Jpg/Common.hs b/src/Codec/Picture/Jpg/Common.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Common.hs @@ -0,0 +1,232 @@ +{-# LANGUAGE BangPatterns #-} +module Codec.Picture.Jpg.Common + ( DctCoefficients + , JpgUnpackerParameter( .. ) + , decodeInt + , dcCoefficientDecode + , deQuantize + , decodeRrrrSsss + , zigZagReorderForward + , zigZagReorderForwardv + , zigZagReorder + , inverseDirectCosineTransform + , unpackInt + , unpackMacroBlock + , rasterMap + , decodeMacroBlock + , decodeRestartInterval + ) where + +import Control.Applicative( (<$>), pure ) +import Control.Monad( replicateM, when ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) +import Data.Int( Int16, Int32 ) +import Data.List( foldl' ) +import Data.Maybe( fromMaybe ) +import Data.Word( Word8 ) +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import Foreign.Storable ( Storable ) + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.FastIdct +import Codec.Picture.Jpg.DefaultTable + +-- | Same as for DcCoefficient, to provide nicer type signatures +type DctCoefficients = DcCoefficient + +data JpgUnpackerParameter = JpgUnpackerParameter + { dcHuffmanTree :: !HuffmanPackedTree + , acHuffmanTree :: !HuffmanPackedTree + , componentIndex :: {-# UNPACK #-} !Int + , restartInterval :: {-# UNPACK #-} !Int + , componentWidth :: {-# UNPACK #-} !Int + , componentHeight :: {-# UNPACK #-} !Int + , subSampling :: !(Int, Int) + , coefficientRange :: !(Int, Int) + , successiveApprox :: !(Int, Int) + , readerIndex :: {-# UNPACK #-} !Int + , indiceVector :: {-# UNPACK #-} !Int + , blockIndex :: {-# UNPACK #-} !Int + , blockMcuX :: {-# UNPACK #-} !Int + , blockMcuY :: {-# UNPACK #-} !Int + } + deriving Show + +decodeRestartInterval :: BoolReader s Int32 +decodeRestartInterval = return (-1) {- do + bits <- replicateM 8 getNextBitJpg + if bits == replicate 8 True + then do + marker <- replicateM 8 getNextBitJpg + return $ packInt marker + else return (-1) + -} + +{-# INLINE decodeInt #-} +decodeInt :: Int -> BoolReader s Int32 +decodeInt ssss = do + signBit <- getNextBitJpg + let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) + leftBitCount = ssss - 1 + -- First following bits store the sign of the coefficient, and counted in + -- SSSS, so the bit count for the int, is ssss - 1 + if signBit + then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount + else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount + +decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) +decodeRrrrSsss tree = do + rrrrssss <- huffmanPackedDecode tree + let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF + ssss = rrrrssss .&. 0xF + pure (fromIntegral rrrr, fromIntegral ssss) + +dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient +dcCoefficientDecode dcTree = do + ssss <- huffmanPackedDecode dcTree + if ssss == 0 + then return 0 + else fromIntegral <$> decodeInt (fromIntegral ssss) + +-- | Apply a quantization matrix to a macroblock +{-# INLINE deQuantize #-} +deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +deQuantize table block = update 0 + where update 64 = return block + update i = do + val <- block `M.unsafeRead` i + let finalValue = val * (table `VS.unsafeIndex` i) + (block `M.unsafeWrite` i) finalValue + update $ i + 1 + +inverseDirectCosineTransform :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +inverseDirectCosineTransform mBlock = + fastIdct mBlock >>= mutableLevelShift + +zigZagOrder :: MacroBlock Int +zigZagOrder = makeMacroBlock $ concat + [[ 0, 1, 5, 6,14,15,27,28] + ,[ 2, 4, 7,13,16,26,29,42] + ,[ 3, 8,12,17,25,30,41,43] + ,[ 9,11,18,24,31,40,44,53] + ,[10,19,23,32,39,45,52,54] + ,[20,22,33,38,46,51,55,60] + ,[21,34,37,47,50,56,59,61] + ,[35,36,48,49,57,58,62,63] + ] + +zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a +zigZagReorderForwardv vec = runST $ do + v <- M.new 64 + mv <- VS.thaw vec + zigZagReorderForward v mv >>= VS.freeze + +zigZagOrderForward :: MacroBlock Int +zigZagOrderForward = VS.generate 64 inv + where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder + +zigZagReorderForward :: (Storable a, Num a) + => MutableMacroBlock s a + -> MutableMacroBlock s a + -> ST s (MutableMacroBlock s a) +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int32 + -> ST s (MutableMacroBlock s Int32) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) #-} +{-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 + -> MutableMacroBlock s Word8 + -> ST s (MutableMacroBlock s Word8) #-} +zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged + where ordering !table = reorder (0 :: Int) + where reorder !i | i >= 64 = return () + reorder i = do + let idx = table `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + reorder (i + 1) + +zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +zigZagReorder zigzaged block = do + let update i = do + let idx = zigZagOrder `VS.unsafeIndex` i + v <- block `M.unsafeRead` idx + (zigzaged `M.unsafeWrite` i) v + + reorder 63 = update 63 + reorder i = update i >> reorder (i + 1) + + reorder (0 :: Int) + return zigzaged + +-- | Unpack an int of the given size encoded from MSB to LSB. +unpackInt :: Int -> BoolReader s Int32 +unpackInt bitCount = packInt <$> replicateM bitCount getNextBitJpg + + +{-# INLINE rasterMap #-} +rasterMap :: (Monad m) + => Int -> Int -> (Int -> Int -> m ()) + -> m () +rasterMap width height f = liner 0 + where liner y | y >= height = return () + liner y = columner 0 + where columner x | x >= width = liner (y + 1) + columner x = f x y >> columner (x + 1) + +packInt :: [Bool] -> Int32 +packInt = foldl' bitStep 0 + where bitStep acc True = (acc `unsafeShiftL` 1) + 1 + bitStep acc False = acc `unsafeShiftL` 1 + +pixelClamp :: Int16 -> Word8 +pixelClamp n = fromIntegral . min 255 $ max 0 n + +-- | Given a size coefficient (how much a pixel span horizontally +-- and vertically), the position of the macroblock, return a list +-- of indices and value to be stored in an array (like the final +-- image) +unpackMacroBlock :: Int -- ^ Component count + -> Int -- ^ Width coefficient + -> Int -- ^ Height coefficient + -> Int -- ^ x + -> Int -- ^ y + -> Int -- ^ Component index + -> MutableImage s PixelYCbCr8 + -> MutableMacroBlock s Int16 + -> ST s () +unpackMacroBlock compCount wCoeff hCoeff compIdx x y + (MutableImage { mutableImageWidth = imgWidth, + mutableImageHeight = imgHeight, mutableImageData = img }) + block = rasterMap dctBlockSize dctBlockSize unpacker + where unpacker i j = do + let yBase = y * dctBlockSize + j * hCoeff + compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) + rasterMap wCoeff hCoeff $ \wDup hDup -> do + let xBase = x * dctBlockSize + i * wCoeff + xPos = xBase + wDup + yPos = yBase + hDup + + when (xPos < imgWidth && yPos < imgHeight) + (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx + (img `M.unsafeWrite` mutableIdx) compVal) + +-- | This is one of the most important function of the decoding, +-- it form the barebone decoding pipeline for macroblock. It's all +-- there is to know for macro block transformation +decodeMacroBlock :: MacroBlock DctCoefficients + -> MutableMacroBlock s Int16 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +decodeMacroBlock quantizationTable zigZagBlock block = + deQuantize quantizationTable block >>= zigZagReorder zigZagBlock + >>= inverseDirectCosineTransform + diff --git a/src/Codec/Picture/Jpg/DefaultTable.hs b/src/Codec/Picture/Jpg/DefaultTable.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/DefaultTable.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +-- | Module used by the jpeg decoder internally, shouldn't be used +-- in user code. +module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) + , HuffmanTree( .. ) + , HuffmanTable + , HuffmanPackedTree + , MacroBlock + , QuantificationTable + , HuffmanWriterCode + , scaleQuantisationMatrix + , makeMacroBlock + , makeInverseTable + , buildHuffmanTree + , packHuffmanTree + , huffmanPackedDecode + + , defaultChromaQuantizationTable + + , defaultLumaQuantizationTable + + , defaultAcChromaHuffmanTree + , defaultAcChromaHuffmanTable + + , defaultAcLumaHuffmanTree + , defaultAcLumaHuffmanTable + + , defaultDcChromaHuffmanTree + , defaultDcChromaHuffmanTable + + , defaultDcLumaHuffmanTree + , defaultDcLumaHuffmanTable + ) where + +import Data.Int( Int16 ) +import Foreign.Storable ( Storable ) +import Control.Monad.ST( runST ) +import qualified Data.Vector.Storable as SV +import qualified Data.Vector as V +import Data.Bits( unsafeShiftL, (.|.), (.&.) ) +import Data.Word( Word8, Word16 ) +import Data.List( foldl' ) +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +-- | Tree storing the code used for huffman encoding. +data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. + | Leaf Word8 -- ^ We should output the value + | Empty -- ^ no value present + deriving (Eq, Show) + +type HuffmanPackedTree = SV.Vector Word16 + +type HuffmanWriterCode = V.Vector (Word8, Word16) + +packHuffmanTree :: HuffmanTree -> HuffmanPackedTree +packHuffmanTree tree = runST $ do + table <- M.replicate 512 0x8000 + let aux (Empty) idx = return $ idx + 1 + aux (Leaf v) idx = do + (table `M.unsafeWrite` idx) $ (fromIntegral v .|. 0x4000) + return $ idx + 1 + + aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = + aux i1 idx >>= aux i2 + + aux (Branch i1@(Leaf _) i2) idx = do + _ <- aux i1 idx + ix2 <- aux i2 $ idx + 2 + (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2 + return ix2 + + aux (Branch i1 i2@(Leaf _)) idx = do + ix1 <- aux i1 (idx + 2) + _ <- aux i2 (idx + 1) + (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2 + return ix1 + + aux (Branch i1 i2) idx = do + ix1 <- aux i1 (idx + 2) + ix2 <- aux i2 ix1 + (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2) + (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1) + return ix2 + _ <- aux tree 0 + SV.unsafeFreeze table + +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 `unsafeShiftL` 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 = 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 = SV.fromListN 64 + +-- | Enumeration used to search in the tables for different components. +data DctComponent = DcComponent | AcComponent + deriving (Eq, Show) + +-- | Transform parsed coefficients from the jpeg header to a +-- tree which can be used to decode data. +buildHuffmanTree :: [[Word8]] -> HuffmanTree +buildHuffmanTree table = foldl' insertHuffmanVal Empty + . concatMap (\(i, t) -> map (i + 1,) t) + $ zip ([0..] :: [Int]) table + where isTreeFullyDefined Empty = False + isTreeFullyDefined (Leaf _) = True + isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r + + insertHuffmanVal Empty (0, val) = Leaf val + insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty + insertHuffmanVal (Branch l r) (d, val) + | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) + | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r + insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" + +scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable +scaleQuantisationMatrix quality + | quality < 0 = scaleQuantisationMatrix 0 + -- shouldn't show much difference than with 1, + -- but hey, at least we're complete + | quality == 0 = SV.map (scale (10000 :: Int)) + | 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 + +huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8 +huffmanPackedDecode table = getNextBitJpg >>= aux 0 + where aux idx b + | (v .&. 0x8000) /= 0 = return 0 + | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF + | otherwise = getNextBitJpg >>= aux v + where tableIndex | b = idx + 1 + | otherwise = idx + v = table `SV.unsafeIndex` fromIntegral tableIndex + +defaultLumaQuantizationTable :: QuantificationTable +defaultLumaQuantizationTable = makeMacroBlock + [16, 11, 10, 16, 24, 40, 51, 61 + ,12, 12, 14, 19, 26, 58, 60, 55 + ,14, 13, 16, 24, 40, 57, 69, 56 + ,14, 17, 22, 29, 51, 87, 80, 62 + ,18, 22, 37, 56, 68, 109, 103, 77 + ,24, 35, 55, 64, 81, 104, 113, 92 + ,49, 64, 78, 87, 103, 121, 120, 101 + ,72, 92, 95, 98, 112, 100, 103, 99 + ] + +defaultChromaQuantizationTable :: QuantificationTable +defaultChromaQuantizationTable = makeMacroBlock + [17, 18, 24, 47, 99, 99, 99, 99 + ,18, 21, 26, 66, 99, 99, 99, 99 + ,24, 26, 56, 99, 99, 99, 99, 99 + ,47, 66, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,99, 99, 99, 99, 99, 99, 99, 99 + ,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 :: HuffmanTable +defaultDcLumaHuffmanTable = + [ [] + , [0] + , [1, 2, 3, 4, 5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + , [] + , [] + ] + +defaultDcChromaHuffmanTree :: HuffmanTree +defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable + +-- | From the Table K.4 of ITU-81 (p153) +defaultDcChromaHuffmanTable :: HuffmanTable +defaultDcChromaHuffmanTable = + [ [] + , [0, 1, 2] + , [3] + , [4] + , [5] + , [6] + , [7] + , [8] + , [9] + , [10] + , [11] + , [] + , [] + , [] + , [] + , [] + ] + +defaultAcLumaHuffmanTree :: HuffmanTree +defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable + +-- | From the Table K.5 of ITU-81 (p154) +defaultAcLumaHuffmanTable :: HuffmanTable +defaultAcLumaHuffmanTable = + [ [] + , [0x01, 0x02] + , [0x03] + , [0x00, 0x04, 0x11] + , [0x05, 0x12, 0x21] + , [0x31, 0x41] + , [0x06, 0x13, 0x51, 0x61] + , [0x07, 0x22, 0x71] + , [0x14, 0x32, 0x81, 0x91, 0xA1] + , [0x08, 0x23, 0x42, 0xB1, 0xC1] + , [0x15, 0x52, 0xD1, 0xF0] + , [0x24, 0x33, 0x62, 0x72] + , [] + , [] + , [0x82] + , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 + ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 + ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A + ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 + ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 + ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA + ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 + ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] + ] + +type HuffmanTable = [[Word8]] + +defaultAcChromaHuffmanTree :: HuffmanTree +defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable + +defaultAcChromaHuffmanTable :: HuffmanTable +defaultAcChromaHuffmanTable = + [ [] + , [0x00, 0x01] + , [0x02] + , [0x03, 0x11] + , [0x04, 0x05, 0x21, 0x31] + , [0x06, 0x12, 0x41, 0x51] + , [0x07, 0x61, 0x71] + , [0x13, 0x22, 0x32, 0x81] + , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] + , [0x09, 0x23, 0x33, 0x52, 0xF0] + , [0x15, 0x62, 0x72, 0xD1] + , [0x0A, 0x16, 0x24, 0x34] + , [] + , [0xE1] + , [0x25, 0xF1] + , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 + , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 + , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 + , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 + , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 + , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 + , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 + , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 + , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 + , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 + , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA + , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA + ] + ] + diff --git a/src/Codec/Picture/Jpg/FastDct.hs b/src/Codec/Picture/Jpg/FastDct.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/FastDct.hs @@ -0,0 +1,203 @@ +module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where + +import Control.Applicative( (<$>) ) +import Data.Int( Int16, Int32 ) +import Data.Bits( Bits, unsafeShiftR, unsafeShiftL ) +import Control.Monad.ST( ST ) + +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Jpg.Types +import Control.Monad( forM, forM_ ) + +-- | 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 .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] (\(u,v) -> do + val <- at (u,v) + (workData `M.unsafeWrite` (v * dctBlockSize + 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..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do + sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + 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 _ i | i == dctBlockSize = return () + firstPass dataBlock i = do + let baseIdx = i * dctBlockSize + readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) + mult = (*) + writeAt idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) n + writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) + (n `unsafeShiftR` (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 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (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 `unsafeShiftL` (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 `M.unsafeRead` ((7 - i) + idx * dctBlockSize) + mult = (*) + writeAt idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) n + writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (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 `unsafeShiftL` (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) `unsafeShiftR` (pASS1_BITS + 3) + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (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 `unsafeShiftL` (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/src/Codec/Picture/Jpg/FastIdct.hs b/src/Codec/Picture/Jpg/FastIdct.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/FastIdct.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE FlexibleContexts #-} +-- | Module providing a 'fast' implementation of IDCT +-- +-- inverse two dimensional DCT, Chen-Wang algorithm +-- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) +-- 32-bit integer arithmetic (8 bit coefficients) +-- 11 mults, 29 adds per DCT +-- sE, 18.8.91 +-- +-- coefficients extended to 12 bit for IEEE1180-1990 +-- compliance sE, 2.1.94 +-- +-- this code assumes >> to be a two's-complement arithmetic +-- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 +module Codec.Picture.Jpg.FastIdct( MutableMacroBlock + , fastIdct + , mutableLevelShift + , createEmptyMutableMacroBlock + ) where + +import qualified Data.Vector.Storable as V +import Control.Monad.ST( ST ) +import Data.Bits( unsafeShiftL, unsafeShiftR ) +import Data.Int( Int16 ) +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Jpg.Types + +iclip :: V.Vector Int16 +iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] + where val i | i < (-256) = -256 + | i > 255 = 255 + | otherwise = i + +data IDctStage = IDctStage { + x0 :: {-# UNPACK #-} !Int, + x1 :: {-# UNPACK #-} !Int, + x2 :: {-# UNPACK #-} !Int, + x3 :: {-# UNPACK #-} !Int, + x4 :: {-# UNPACK #-} !Int, + x5 :: {-# UNPACK #-} !Int, + x6 :: {-# UNPACK #-} !Int, + x7 :: {-# UNPACK #-} !Int, + x8 :: {-# UNPACK #-} !Int + } + +w1, w2, w3, w5, w6, w7 :: Int +w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) +w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) +w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) +w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) +w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) +w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) + +-- row (horizontal) IDCT +-- +-- 7 pi 1 +-- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 128 +-- c[1..7] = 128*sqrt(2) +idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () +idctRow blk idx = do + xx0 <- blk `M.unsafeRead` (0 + idx) + xx1 <- blk `M.unsafeRead` (4 + idx) + xx2 <- blk `M.unsafeRead` (6 + idx) + xx3 <- blk `M.unsafeRead` (2 + idx) + xx4 <- blk `M.unsafeRead` (1 + idx) + xx5 <- blk `M.unsafeRead` (7 + idx) + xx6 <- blk `M.unsafeRead` (5 + idx) + xx7 <- blk `M.unsafeRead` (3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128 + , x1 = fromIntegral xx1 `unsafeShiftL` 11 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + + firstStage c = c { x4 = x8' + (w1 - w7) * x4 c + , x5 = x8' - (w1 + w7) * x5 c + , x6 = x8'' - (w3 - w5) * x6 c + , x7 = x8'' - (w3 + w5) * x7 c + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + x8'' = w3 * (x6 c + x7 c) + + secondStage c = c { x0 = x0 c - x1 c + , x8 = x0 c + x1 c + , x1 = x1'' + , x2 = x1' - (w2 + w6) * x2 c + , x3 = x1' + (w2 - w6) * x3 c + , x4 = x4 c - x6 c + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 + , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 + } + scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8 + , x1 = (x3 c + x2 c) `unsafeShiftR` 8 + , x2 = (x0 c + x4 c) `unsafeShiftR` 8 + , x3 = (x8 c + x6 c) `unsafeShiftR` 8 + , x4 = (x8 c - x6 c) `unsafeShiftR` 8 + , x5 = (x0 c - x4 c) `unsafeShiftR` 8 + , x6 = (x3 c - x2 c) `unsafeShiftR` 8 + , x7 = (x7 c - x1 c) `unsafeShiftR` 8 + } + transformed = scaled . thirdStage . secondStage $ firstStage initialState + + (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed + (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed + (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed + (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed + (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed + (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed + (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed + (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed + +-- column (vertical) IDCT +-- +-- 7 pi 1 +-- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) +-- l=0 8 2 +-- +-- where: c[0] = 1/1024 +-- c[1..7] = (1/1024)*sqrt(2) +-- +idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () +idctCol blk idx = do + xx0 <- blk `M.unsafeRead` ( 0 + idx) + xx1 <- blk `M.unsafeRead` (8 * 4 + idx) + xx2 <- blk `M.unsafeRead` (8 * 6 + idx) + xx3 <- blk `M.unsafeRead` (8 * 2 + idx) + xx4 <- blk `M.unsafeRead` (8 + idx) + xx5 <- blk `M.unsafeRead` (8 * 7 + idx) + xx6 <- blk `M.unsafeRead` (8 * 5 + idx) + xx7 <- blk `M.unsafeRead` (8 * 3 + idx) + let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192 + , x1 = fromIntegral xx1 `unsafeShiftL` 8 + , x2 = fromIntegral xx2 + , x3 = fromIntegral xx3 + , x4 = fromIntegral xx4 + , x5 = fromIntegral xx5 + , x6 = fromIntegral xx6 + , x7 = fromIntegral xx7 + , x8 = 0 + } + firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) `unsafeShiftR` 3 + , x5 = (x8' - (w1 + w7) * x5 c) `unsafeShiftR` 3 + , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3 + , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3 + , x8 = x8'' + } + where x8' = w7 * (x4 c + x5 c) + 4 + x8'' = w3 * (x6 c + x7 c) + 4 + + secondStage c = c { x8 = x0 c + x1 c + , x0 = x0 c - x1 c + , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3 + , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3 + , x4 = x4 c - x6 c + , x1 = x1'' + , x6 = x5 c + x7 c + , x5 = x5 c - x7 c + } + where x1' = w6 * (x3 c + x2 c) + 4 + x1'' = x4 c + x6 c + + thirdStage c = c { x7 = x8 c + x3 c + , x8 = x8 c - x3 c + , x3 = x0 c + x2 c + , x0 = x0 c - x2 c + , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 + , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 + } + + clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512) + else iclip `V.unsafeIndex` 0 + + | otherwise = iclip `V.unsafeIndex` 1023 + + f = thirdStage . secondStage $ firstStage initialState + (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8 )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14 + (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14 + + +{-# INLINE fastIdct #-} +-- | Algorithm to call to perform an IDCT, return the same +-- block that the one given as input. +fastIdct :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +fastIdct block = rows 0 + where rows 8 = cols 0 + rows i = idctRow block (8 * i) >> rows (i + 1) + + cols 8 = return block + cols i = idctCol block i >> cols (i + 1) + +{-# INLINE mutableLevelShift #-} +-- | Perform a Jpeg level shift in a mutable fashion. +mutableLevelShift :: MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int16) +mutableLevelShift block = update 0 + where update 64 = return block + update idx = do + val <- block `M.unsafeRead` idx + (block `M.unsafeWrite` idx) $ val + 128 + update $ idx + 1 + diff --git a/src/Codec/Picture/Jpg/Progressive.hs b/src/Codec/Picture/Jpg/Progressive.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Progressive.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Codec.Picture.Jpg.Progressive + ( JpgUnpackerParameter( .. ) + , progressiveUnpack + ) where + +import Control.Applicative( pure, (<$>) ) +import Control.Monad( when, forM_ ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import Data.Bits( (.&.), (.|.), unsafeShiftL ) +import Data.Int( Int16, Int32 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Vector( (!) ) +import qualified Data.Vector.Mutable as M +import qualified Data.Vector.Storable.Mutable as MS + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Common +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.DefaultTable + +createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) +createMcuLineIndices param imgWidth mcuWidth = + V.fromList $ VS.fromList <$> [indexSolo, indexMulti] + where compW = fromIntegral $ horizontalSamplingFactor param + compH = fromIntegral $ verticalSamplingFactor param + imageBlockSize = (imgWidth + 7) `div` 8 + + indexSolo = + [y * mcuWidth * compW + x + | y <- [0 .. compH - 1], x <- [0 .. imageBlockSize - 1]] + + indexMulti = + [(mcu + y * mcuWidth) * compW + x + | mcu <- [0 .. mcuWidth - 1] + , y <- [0 .. compH - 1] + , x <- [0 .. compW - 1] ] + +decodeFirstDC :: JpgUnpackerParameter + -> MS.STVector s Int16 + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun + where unpack = do + (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params + previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params + let neoDcCoefficient = previousDc + dcDeltaCoefficient + approxLow = fst $ successiveApprox params + scaledDc = neoDcCoefficient `unsafeShiftL` approxLow + lift $ (block `MS.unsafeWrite` 0) scaledDc + lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient + +decodeRefineDc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineDc params _ block eobrun = unpack >> pure eobrun + where approxLow = fst $ successiveApprox params + plusOne = 1 `unsafeShiftL` approxLow + unpack = do + bit <- getNextBitJpg + when bit . lift $ do + v <- block `MS.unsafeRead` 0 + (block `MS.unsafeWrite` 0) $ v .|. plusOne + +decodeFirstAc :: JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 +decodeFirstAc params _ block _ = unpack startIndex + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + unpack n | n > maxIndex = pure 0 + unpack n = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> unpack $ n + 16 + ( 0, 0) -> return 0 + ( r, 0) -> eobrun <$> unpackInt r + where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits + ( r, s) -> do + let n' = n + r + val <- (`unsafeShiftL` low) <$> decodeInt s + lift . (block `MS.unsafeWrite` n') $ fromIntegral val + unpack $ n' + 1 + +decodeRefineAc :: forall a s. JpgUnpackerParameter + -> a + -> MutableMacroBlock s Int16 + -> Int32 + -> BoolReader s Int32 +decodeRefineAc params _ block eobrun + | eobrun == 0 = unpack startIndex + | otherwise = performEobRun startIndex >> return (eobrun - 1) + where (startIndex, maxIndex) = coefficientRange params + (low, _) = successiveApprox params + plusOne = 1 `unsafeShiftL` low + minusOne = (-1) `unsafeShiftL` low + + getBitVal = do + v <- getNextBitJpg + pure $ if v then plusOne else minusOne + + {-performEobRun :: Int -> BoolReader s ()-} + performEobRun idx | idx > maxIndex = pure () + performEobRun idx = do + coeff <- lift $ block `MS.unsafeRead` idx + when (coeff /= 0) $ do + bit <- getNextBitJpg + case (bit, (coeff .&. plusOne) == 0) of + (False, _) -> performEobRun $ idx + 1 + (True, False) -> performEobRun $ idx + 1 + (True, True) -> do + let newVal | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) newVal + performEobRun $ idx + 1 + + unpack idx | idx > maxIndex = pure 0 + unpack idx = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> do + idx' <- updateCoeffs 0x10 idx + unpack $ idx' + + ( r, 0) -> do + lowBits <- unpackInt r + let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 + performEobRun idx + pure newEobRun + + ( r, _) -> do + idx' <- updateCoeffs (fromIntegral r) idx + val <- getBitVal + when (idx <= maxIndex) $ + (lift $ (block `MS.unsafeWrite` idx') val) + unpack $ idx' + 1 + + updateCoeffs :: Int -> Int -> BoolReader s Int + updateCoeffs r idx + | r < 0 = pure idx + | idx > maxIndex = pure idx + updateCoeffs r idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + when (bit && coeff .&. plusOne == 0) $ + if coeff >= 0 then + lift . (block `MS.unsafeWrite` idx) $ coeff + plusOne + else + lift . (block `MS.unsafeWrite` idx) $ coeff + minusOne + updateCoeffs r $ idx + 1 + else + updateCoeffs (r - 1) $ idx + 1 + +type Unpacker s = + JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 + -> BoolReader s Int32 + + +prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) + , M.STVector s BoolState) +prepareUnpacker lst = do + let boolStates = V.fromList $ map snd infos + vec <- V.unsafeThaw boolStates + return (V.fromList $ map fst infos, vec) + where infos = map prepare lst + prepare ([], _) = error "progressiveUnpack, no component" + prepare (whole@((param, _) : _) , byteString) = + (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) + where unpacker = selection (successiveApprox param) (coefficientRange param) + boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString + + selection (_, 0) (0, _) = decodeFirstDC + selection (_, 0) _ = decodeFirstAc + selection _ (0, _) = decodeRefineDc + selection _ _ = decodeRefineAc + +data ComponentData s = ComponentData + { componentIndices :: V.Vector (VS.Vector Int) + , componentBlocks :: V.Vector (MutableMacroBlock s Int16) + , componentId :: !Int + , componentBlockCount :: !Int + } + +-- | Iteration from to n in monadic context, without data +-- keeping. +lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () +{-# INLINE lineMap #-} +lineMap count f = go 0 + where go n | n >= count = return () + go n = f n >> go (n + 1) + +progressiveUnpack :: (Int, Int) + -> JpgFrameHeader + -> V.Vector (MacroBlock Int16) + -> [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s (MutableImage s PixelYCbCr8) +progressiveUnpack (maxiW, maxiH) frame quants lst = do + (unpackers, readers) <- prepareUnpacker lst + allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame + :: ST s [ComponentData s] + let scanCount = length lst + restartIntervalValue = case lst of + ((p,_):_,_): _ -> restartInterval p + _ -> -1 + dcCoeffs <- MS.replicate imgComponentCount 0 + eobRuns <- MS.replicate (length lst) 0 + workBlock <- createEmptyMutableMacroBlock + writeIndices <- MS.replicate imgComponentCount (0 :: Int) + restartIntervals <- MS.replicate scanCount restartIntervalValue + let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount + img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 + + let processRestartInterval = + forM_ [0 .. scanCount - 1] $ \ix -> do + v <- restartIntervals `MS.read` ix + if v == 0 then do + -- reset DC prediction + when (ix == 0) (MS.set dcCoeffs 0) + reader <- readers `M.read` ix + (_, updated) <- runBoolReaderWith reader $ + byteAlignJpg >> decodeRestartInterval + (readers `M.write` ix) updated + (eobRuns `MS.unsafeWrite` ix) 0 + (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 + else + (restartIntervals `MS.unsafeWrite` ix) $ v - 1 + + + lineMap imageMcuHeight $ \mmY -> do + -- Reset all blocks to 0 + forM_ allBlocks $ V.mapM_ (flip MS.set 0) . componentBlocks + MS.set writeIndices 0 + + lineMap imageMcuWidth $ \_mmx -> do + processRestartInterval + V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do + boolState <- readers `M.read` readerIndex unpackParam + eobrun <- eobRuns `MS.read` readerIndex unpackParam + let componentNumber = componentIndex unpackParam + writeIndex <- writeIndices `MS.read` componentNumber + let componentData = allBlocks !! componentNumber + indexVector = + componentIndices componentData ! indiceVector unpackParam + maxIndexLength = VS.length indexVector + if writeIndex + blockIndex unpackParam >= maxIndexLength then + return () + else do + let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) + writeBlock = componentBlocks componentData ! realIndex + (eobrun', state) <- + runBoolReaderWith boolState $ + unpacker unpackParam dcCoeffs writeBlock eobrun + + (readers `M.write` readerIndex unpackParam) state + (eobRuns `MS.write` readerIndex unpackParam) eobrun' + + -- Update the write indices + forM_ allBlocks $ \comp -> do + writeIndex <- writeIndices `MS.read` componentId comp + let newIndex = writeIndex + componentBlockCount comp + (writeIndices `MS.write` componentId comp) $ newIndex + + forM_ allBlocks $ \compData -> do + let compBlocks = componentBlocks compData + cId = componentId compData + table = quants ! min 1 cId + comp = jpgComponents frame !! cId + compW = fromIntegral $ horizontalSamplingFactor comp + compH = fromIntegral $ verticalSamplingFactor comp + cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 + ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 + + rasterMap (imageMcuWidth * compW) compH $ \rx y -> do + let ry = mmY * maxiH + y + block = compBlocks ! (y * imageMcuWidth * compW + rx) + transformed <- decodeMacroBlock table workBlock block + unpackMacroBlock imgComponentCount + cw8 ch8 cId (rx * cw8) ry + img transformed + + return img + + where imgComponentCount = length $ jpgComponents frame + + imgWidth = fromIntegral $ jpgWidth frame + imgHeight = fromIntegral $ jpgHeight frame + + imageBlockWidth = (imgWidth + 7) `div` 8 + imageBlockHeight = (imgHeight + 7) `div` 8 + + imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW + imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH + + allocateWorkingBlocks (ix, comp) = do + let blockCount = hSample * vSample * imageMcuWidth + blocks <- V.replicateM blockCount createEmptyMutableMacroBlock + return $ ComponentData + { componentBlocks = blocks + , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth + , componentBlockCount = hSample * vSample + , componentId = ix + } + where hSample = fromIntegral $ horizontalSamplingFactor comp + vSample = fromIntegral $ verticalSamplingFactor comp + diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Types.hs @@ -0,0 +1,546 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Codec.Picture.Jpg.Types( MutableMacroBlock + , createEmptyMutableMacroBlock + , printMacroBlock + , printPureMacroBlock + , DcCoefficient + , JpgImage( .. ) + , JpgComponent( .. ) + , JpgFrameHeader( .. ) + , JpgFrame( .. ) + , JpgFrameKind( .. ) + , JpgScanHeader( .. ) + , JpgQuantTableSpec( .. ) + , JpgHuffmanTableSpec( .. ) + , JpgImageKind( .. ) + , JpgScanSpecification( .. ) + , calculateSize + , dctBlockSize + ) where + +import Control.Applicative( (<$>), (<*>)) +import Control.Monad( when, replicateM, forM, forM_, unless ) +import Control.Monad.ST( ST ) +import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) +import Foreign.Storable ( Storable ) +import Data.Vector.Unboxed( (!) ) +import qualified Data.Vector as V +import qualified Data.Vector.Unboxed as VU +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +import Data.Int( Int16 ) +import Data.Word(Word8, Word16 ) +import Data.Binary( Binary(..) ) + +import Data.Binary.Get( Get + , getWord8 + , getWord16be + , getByteString + , skip + , bytesRead + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16be + , putLazyByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Jpg.DefaultTable + +{-import Debug.Trace-} +import Text.Printf + +-- | Type only used to make clear what kind of integer we are carrying +-- Might be transformed into newtype in the future +type DcCoefficient = Int16 + +-- | Macroblock that can be transformed. +type MutableMacroBlock s a = M.STVector s a + +data JpgFrameKind = + JpgBaselineDCTHuffman + | JpgExtendedSequentialDCTHuffman + | JpgProgressiveDCTHuffman + | JpgLosslessHuffman + | JpgDifferentialSequentialDCTHuffman + | JpgDifferentialProgressiveDCTHuffman + | JpgDifferentialLosslessHuffman + | JpgExtendedSequentialArithmetic + | JpgProgressiveDCTArithmetic + | JpgLosslessArithmetic + | JpgDifferentialSequentialDCTArithmetic + | JpgDifferentialProgressiveDCTArithmetic + | JpgDifferentialLosslessArithmetic + | JpgQuantizationTable + | JpgHuffmanTableMarker + | JpgStartOfScan + | JpgEndOfImage + | JpgAppSegment Word8 + | JpgExtensionSegment Word8 + + | JpgRestartInterval + | JpgRestartIntervalEnd Word8 + deriving (Eq, Show) + +data JpgFrame = + JpgAppFrame !Word8 B.ByteString + | JpgExtension !Word8 B.ByteString + | JpgQuantTable ![JpgQuantTableSpec] + | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] + | JpgScanBlob !JpgScanHeader !L.ByteString + | JpgScans !JpgFrameKind !JpgFrameHeader + | JpgIntervalRestart !Word16 + deriving Show + +data JpgFrameHeader = JpgFrameHeader + { jpgFrameHeaderLength :: !Word16 + , jpgSamplePrecision :: !Word8 + , jpgHeight :: !Word16 + , jpgWidth :: !Word16 + , jpgImageComponentCount :: !Word8 + , 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 + , horizontalSamplingFactor :: !Word8 + -- | Stored with 4 bits + , verticalSamplingFactor :: !Word8 + , quantizationTableDest :: !Word8 + } + deriving Show + +instance SizeCalculable JpgComponent where + calculateSize _ = 3 + +data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } + deriving Show + +data JpgScanSpecification = JpgScanSpecification + { componentSelector :: !Word8 + -- | Encoded as 4 bits + , dcEntropyCodingTable :: !Word8 + -- | Encoded as 4 bits + , acEntropyCodingTable :: !Word8 + + } + deriving Show + +instance SizeCalculable JpgScanSpecification where + calculateSize _ = 2 + +data JpgScanHeader = JpgScanHeader + { scanLength :: !Word16 + , scanComponentCount :: !Word8 + , scans :: [JpgScanSpecification] + + -- | (begin, end) + , spectralSelection :: (Word8, Word8) + + -- | Encoded as 4 bits + , successiveApproxHigh :: !Word8 + + -- | Encoded as 4 bits + , successiveApproxLow :: !Word8 + } + 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 + + -- | Stored on 4 bits + , quantDestination :: !Word8 + + , quantTable :: MacroBlock Int16 + } + deriving Show + +class SizeCalculable a where + calculateSize :: a -> Int + +-- | Type introduced only to avoid some typeclass overlapping +-- problem +newtype TableList a = TableList [a] + +instance (SizeCalculable a, Binary a) => Binary (TableList a) where + put (TableList lst) = do + putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 + mapM_ put lst + + get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) + where innerParse :: Int -> Get [a] + innerParse 0 = return [] + innerParse size = do + onStart <- fromIntegral <$> bytesRead + table <- get + onEnd <- fromIntegral <$> bytesRead + (table :) <$> innerParse (size - (onEnd - onStart)) + +instance SizeCalculable JpgQuantTableSpec where + calculateSize table = + 1 + (fromIntegral (quantPrecision table) + 1) * 64 + +instance Binary JpgQuantTableSpec where + put table = do + let precision = quantPrecision table + put4BitsOfEach precision (quantDestination table) + forM_ (VS.toList $ quantTable table) $ \coeff -> + if precision == 0 then putWord8 $ fromIntegral coeff + else putWord16be $ fromIntegral coeff + + get = do + (precision, dest) <- get4BitOfEach + coeffs <- replicateM 64 $ if precision == 0 + then fromIntegral <$> getWord8 + else fromIntegral <$> getWord16be + return JpgQuantTableSpec + { quantPrecision = precision + , quantDestination = dest + , quantTable = VS.fromListN 64 coeffs + } + +data JpgHuffmanTableSpec = JpgHuffmanTableSpec + { -- | 0 : DC, 1 : AC, stored on 4 bits + huffmanTableClass :: !DctComponent + -- | Stored on 4 bits + , huffmanTableDest :: !Word8 + + , huffSizes :: !(VU.Vector Word8) + , huffCodes :: !(V.Vector (VU.Vector Word8)) + } + deriving Show + +instance SizeCalculable JpgHuffmanTableSpec where + calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] + +instance Binary JpgHuffmanTableSpec where + put table = do + let classVal = if huffmanTableClass table == DcComponent + then 0 else 1 + put4BitsOfEach classVal $ huffmanTableDest table + mapM_ put . VU.toList $ huffSizes table + forM_ [0 .. 15] $ \i -> + when (huffSizes table ! i /= 0) + (let elements = VU.toList $ huffCodes table V.! i + in mapM_ put elements) + + get = do + (huffClass, huffDest) <- get4BitOfEach + sizes <- replicateM 16 getWord8 + codes <- forM sizes $ \s -> + VU.replicateM (fromIntegral s) getWord8 + return JpgHuffmanTableSpec + { huffmanTableClass = + if huffClass == 0 then DcComponent else AcComponent + , huffmanTableDest = huffDest + , huffSizes = VU.fromListN 16 sizes + , huffCodes = V.fromListN 16 codes + } + +instance Binary JpgImage where + put (JpgImage { jpgFrame = frames }) = + putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames + >> putWord8 0xFF >> putWord8 0xD9 + + get = do + let startOfImageMarker = 0xD8 + -- endOfImageMarker = 0xD9 + checkMarker commonMarkerFirstByte startOfImageMarker + eatUntilCode + frames <- parseFrames + {-checkMarker commonMarkerFirstByte endOfImageMarker-} + return JpgImage { jpgFrame = frames } + +eatUntilCode :: Get () +eatUntilCode = do + code <- getWord8 + unless (code == 0xFF) eatUntilCode + +takeCurrentFrame :: Get B.ByteString +takeCurrentFrame = do + size <- getWord16be + getByteString (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 >> putLazyByteString blob +putFrame (JpgScans kind hdr) = + put kind >> put hdr + +-------------------------------------------------- +---- Serialization instances +-------------------------------------------------- +commonMarkerFirstByte :: Word8 +commonMarkerFirstByte = 0xFF + +checkMarker :: Word8 -> Word8 -> Get () +checkMarker b1 b2 = do + rb1 <- getWord8 + rb2 <- getWord8 + when (rb1 /= b1 || rb2 /= b2) + (fail "Invalid marker used") + +extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) +extractScanContent str = aux 0 + where maxi = fromIntegral $ L.length str - 1 + + aux n | n >= maxi = (str, L.empty) + | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str + | otherwise = aux (n + 1) + where v = str `L.index` n + vNext = str `L.index` (n + 1) + isReset = 0xD0 <= vNext && vNext <= 0xD7 + +parseFrames :: Get [JpgFrame] +parseFrames = do + kind <- get + let parseNextFrame = do + word <- getWord8 + when (word /= 0xFF) $ do + readedData <- bytesRead + fail $ "Invalid Frame marker (" ++ show word + ++ ", bytes read : " ++ show readedData ++ ")" + parseFrames + + case kind of + JpgEndOfImage -> return [] + JpgAppSegment c -> + (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame + JpgExtensionSegment c -> + (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame + JpgQuantizationTable -> + (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame + JpgRestartInterval -> + (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame + JpgHuffmanTableMarker -> + (\(TableList huffTables) lst -> + JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) + <$> get <*> parseNextFrame + JpgStartOfScan -> + (\frm imgData -> + let (d, other) = extractScanContent imgData + in + case runGet parseFrames (L.drop 1 other) of + Left _ -> [JpgScanBlob frm d] + Right lst -> JpgScanBlob frm d : lst + ) <$> get <*> getRemainingLazyBytes + + _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame + +buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree +buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList + +secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 +secondStartOfFrameByteOfKind = aux + where + aux JpgBaselineDCTHuffman = 0xC0 + aux JpgExtendedSequentialDCTHuffman = 0xC1 + aux JpgProgressiveDCTHuffman = 0xC2 + aux JpgLosslessHuffman = 0xC3 + aux JpgDifferentialSequentialDCTHuffman = 0xC5 + aux JpgDifferentialProgressiveDCTHuffman = 0xC6 + aux JpgDifferentialLosslessHuffman = 0xC7 + aux JpgExtendedSequentialArithmetic = 0xC9 + aux JpgProgressiveDCTArithmetic = 0xCA + aux JpgLosslessArithmetic = 0xCB + aux JpgHuffmanTableMarker = 0xC4 + aux JpgDifferentialSequentialDCTArithmetic = 0xCD + aux JpgDifferentialProgressiveDCTArithmetic = 0xCE + aux JpgDifferentialLosslessArithmetic = 0xCF + aux JpgEndOfImage = 0xD9 + aux JpgQuantizationTable = 0xDB + aux JpgStartOfScan = 0xDA + aux JpgRestartInterval = 0xDD + aux (JpgRestartIntervalEnd v) = v + aux (JpgAppSegment a) = a + aux (JpgExtensionSegment a) = a + +data JpgImageKind = BaseLineDCT | ProgressiveDCT + +instance Binary JpgFrameKind where + put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) + get = do + -- no lookahead :( + {-word <- getWord8-} + word2 <- getWord8 + return $ case word2 of + 0xC0 -> JpgBaselineDCTHuffman + 0xC1 -> JpgExtendedSequentialDCTHuffman + 0xC2 -> JpgProgressiveDCTHuffman + 0xC3 -> JpgLosslessHuffman + 0xC4 -> JpgHuffmanTableMarker + 0xC5 -> JpgDifferentialSequentialDCTHuffman + 0xC6 -> JpgDifferentialProgressiveDCTHuffman + 0xC7 -> JpgDifferentialLosslessHuffman + 0xC9 -> JpgExtendedSequentialArithmetic + 0xCA -> JpgProgressiveDCTArithmetic + 0xCB -> JpgLosslessArithmetic + 0xCD -> JpgDifferentialSequentialDCTArithmetic + 0xCE -> JpgDifferentialProgressiveDCTArithmetic + 0xCF -> JpgDifferentialLosslessArithmetic + 0xD9 -> JpgEndOfImage + 0xDA -> JpgStartOfScan + 0xDB -> JpgQuantizationTable + 0xDD -> JpgRestartInterval + a | a >= 0xF0 -> JpgExtensionSegment a + | a >= 0xE0 -> JpgAppSegment a + | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a + | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") + +put4BitsOfEach :: Word8 -> Word8 -> Put +put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b + +get4BitOfEach :: Get (Word8, Word8) +get4BitOfEach = do + val <- get + return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) + +newtype RestartInterval = RestartInterval Word16 + +instance Binary RestartInterval where + put (RestartInterval i) = putWord16be 4 >> putWord16be i + get = do + size <- getWord16be + when (size /= 4) (fail "Invalid jpeg restart interval size") + RestartInterval <$> getWord16be + +instance Binary JpgComponent where + get = do + ident <- getWord8 + (horiz, vert) <- get4BitOfEach + quantTableIndex <- getWord8 + return JpgComponent + { componentIdentifier = ident + , horizontalSamplingFactor = horiz + , verticalSamplingFactor = vert + , quantizationTableDest = quantTableIndex + } + put v = do + put $ componentIdentifier v + put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v + put $ quantizationTableDest v + +instance Binary JpgFrameHeader where + get = do + beginOffset <- fromIntegral <$> bytesRead + frmHLength <- getWord16be + samplePrec <- getWord8 + h <- getWord16be + w <- getWord16be + compCount <- getWord8 + components <- replicateM (fromIntegral compCount) get + endOffset <- fromIntegral <$> bytesRead + when (beginOffset - endOffset < fromIntegral frmHLength) + (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) + return JpgFrameHeader + { jpgFrameHeaderLength = frmHLength + , jpgSamplePrecision = samplePrec + , jpgHeight = h + , jpgWidth = w + , jpgImageComponentCount = compCount + , jpgComponents = components + } + + put v = do + putWord16be $ jpgFrameHeaderLength v + putWord8 $ jpgSamplePrecision v + putWord16be $ jpgHeight v + putWord16be $ jpgWidth v + putWord8 $ jpgImageComponentCount v + mapM_ put $ jpgComponents v + +instance Binary JpgScanSpecification where + put v = do + put $ componentSelector v + put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v + + get = do + compSel <- get + (dc, ac) <- get4BitOfEach + return JpgScanSpecification { + componentSelector = compSel + , dcEntropyCodingTable = dc + , acEntropyCodingTable = ac + } + +instance Binary JpgScanHeader where + get = do + thisScanLength <- getWord16be + compCount <- getWord8 + comp <- replicateM (fromIntegral compCount) get + specBeg <- get + specEnd <- get + (approxHigh, approxLow) <- get4BitOfEach + + return JpgScanHeader { + scanLength = thisScanLength, + scanComponentCount = compCount, + scans = comp, + spectralSelection = (specBeg, specEnd), + successiveApproxHigh = approxHigh, + successiveApproxLow = approxLow + } + + put v = do + putWord16be $ scanLength v + putWord8 $ scanComponentCount v + mapM_ put $ scans v + putWord8 . fst $ spectralSelection v + putWord8 . snd $ spectralSelection v + put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v + +{-# 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 + +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 `M.unsafeRead` i + vn <- pLn (i+1) + return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn + +printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String +printPureMacroBlock block = pLn 0 + where pLn 64 = "===============================\n" + pLn i = str ++ pLn (i + 1) + where str | i `mod` 8 == 0 = printf "\n%5d " v + | otherwise = printf "%5d" v + v = block VS.! i + + +{-# INLINE dctBlockSize #-} +dctBlockSize :: Num a => a +dctBlockSize = 8 diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} +-- | Module used for loading & writing \'Portable Network Graphics\' (PNG) +-- files. The API has two layers, the high level, which load the image without +-- looking deeply about it and the low level, allowing access to data chunks contained +-- in the PNG image. +-- +-- For general use, please use 'decodePng' function. +-- +-- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) +module Codec.Picture.Png( -- * High level functions + PngSavable( .. ) + + , decodePng + , writePng + , encodePalettedPng + , encodeDynamicPng + , writeDynamicPng + + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( forM_, foldM_, when ) +import Control.Monad.ST( ST, runST ) +import Data.Binary( Binary( get) ) + +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M +import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.List( find, zip4 ) +import Data.Word( Word8, Word16, Word32 ) +import qualified Codec.Compression.Zlib as Z +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as BU +import qualified Data.ByteString.Lazy as Lb +import Foreign.Storable ( Storable ) + +import Codec.Picture.Types +import Codec.Picture.Png.Type +import Codec.Picture.Png.Export +import Codec.Picture.InternalHelper + +-- | Simple structure used to hold information about Adam7 deinterlacing. +-- A structure is used to avoid pollution of the module namespace. +data Adam7MatrixInfo = Adam7MatrixInfo + { adam7StartingRow :: [Int] + , adam7StartingCol :: [Int] + , adam7RowIncrement :: [Int] + , adam7ColIncrement :: [Int] + , adam7BlockHeight :: [Int] + , adam7BlockWidth :: [Int] + } + +-- | The real info about the matrix. +adam7MatrixInfo :: Adam7MatrixInfo +adam7MatrixInfo = Adam7MatrixInfo + { adam7StartingRow = [0, 0, 4, 0, 2, 0, 1] + , adam7StartingCol = [0, 4, 0, 2, 0, 1, 0] + , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2] + , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1] + , adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1] + , adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1] + } + +unparsePngFilter :: Word8 -> Either String PngFilter +{-# INLINE unparsePngFilter #-} +unparsePngFilter 0 = Right FilterNone +unparsePngFilter 1 = Right FilterSub +unparsePngFilter 2 = Right FilterUp +unparsePngFilter 3 = Right FilterAverage +unparsePngFilter 4 = Right FilterPaeth +unparsePngFilter _ = Left "Invalid scanline filter" + +getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int) +{-# INLINE getBounds #-} +getBounds v = return (0, M.length v - 1) + +-- | Apply a filtering method on a reduced image. Apply the filter +-- on each line, using the previous line (the one above it) to perform +-- some prediction on the value. +pngFiltering :: LineUnpacker s -> Int -> (Int, Int) -- ^ Image size + -> B.ByteString -> Int + -> ST s Int +pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx + | imgWidth <= 0 || imgHeight <= 0 = return initialIdx +pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do + thisLine <- M.replicate (beginZeroes + imgWidth) 0 + otherLine <- M.replicate (beginZeroes + imgWidth) 0 + let folder _ _ lineIndex !idx | lineIndex >= imgHeight = return idx + folder previousLine currentLine lineIndex !idx = do + let byte = str `BU.unsafeIndex` idx + let lineFilter = case unparsePngFilter byte of + Right FilterNone -> filterNone + Right FilterSub -> filterSub + Right FilterAverage -> filterAverage + Right FilterUp -> filterUp + Right FilterPaeth -> filterPaeth + _ -> filterNone + idx' <- lineFilter previousLine currentLine $ idx + 1 + unpacker lineIndex (stride, currentLine) + folder currentLine previousLine (lineIndex + 1) idx' + + folder thisLine otherLine (0 :: Int) initialIdx + + where stride = fromIntegral beginZeroes + lastIdx = beginZeroes + imgWidth - 1 + + -- The filter implementation are... well non-idiomatic + -- to say the least, but my benchmarks proved me one thing, + -- they are faster than mapM_, gained something like 5% with + -- a rewrite from mapM_ to this direct version + filterNone, filterSub, filterUp, filterPaeth, + filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int + filterNone !_previousLine !thisLine = inner beginZeroes + where inner idx !readIdx + | idx > lastIdx = return readIdx + | otherwise = do let byte = str `BU.unsafeIndex` readIdx + (thisLine `M.unsafeWrite` idx) byte + inner (idx + 1) $ readIdx + 1 + + filterSub !_previousLine !thisLine = inner beginZeroes + where inner idx !readIdx + | idx > lastIdx = return readIdx + | otherwise = do let byte = str `BU.unsafeIndex` readIdx + val <- thisLine `M.unsafeRead` (idx - stride) + (thisLine `M.unsafeWrite` idx) $ byte + val + inner (idx + 1) $ readIdx + 1 + + filterUp !previousLine !thisLine = inner beginZeroes + where inner idx !readIdx + | idx > lastIdx = return readIdx + | otherwise = do let byte = str `BU.unsafeIndex` readIdx + val <- previousLine `M.unsafeRead` idx + (thisLine `M.unsafeWrite` idx) $ val + byte + inner (idx + 1) $ readIdx + 1 + + filterAverage !previousLine !thisLine = inner beginZeroes + where inner idx !readIdx + | idx > lastIdx = return readIdx + | otherwise = do let byte = str `BU.unsafeIndex` readIdx + valA <- thisLine `M.unsafeRead` (idx - stride) + valB <- previousLine `M.unsafeRead` idx + let a' = fromIntegral valA + b' = fromIntegral valB + average = fromIntegral ((a' + b') `div` (2 :: Word16)) + writeVal = byte + average + (thisLine `M.unsafeWrite` idx) $ writeVal + inner (idx + 1) $ readIdx + 1 + + filterPaeth !previousLine !thisLine = inner beginZeroes + where inner idx !readIdx + | idx > lastIdx = return readIdx + | otherwise = do let byte = str `BU.unsafeIndex` readIdx + valA <- thisLine `M.unsafeRead` (idx - stride) + valC <- previousLine `M.unsafeRead` (idx - stride) + valB <- previousLine `M.unsafeRead` idx + (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC + inner (idx + 1) $ readIdx + 1 + + paeth a b c + | pa <= pb && pa <= pc = a + | pb <= pc = b + | otherwise = c + where a' = fromIntegral a :: Int + b' = fromIntegral b + c' = fromIntegral c + p = a' + b' - c' + pa = abs $ p - a' + pb = abs $ p - b' + pc = abs $ p - c' + +-- | Directly stolen from the definition in the standard (on W3C page), +-- pixel predictor. + +type PngLine s = M.STVector s Word8 +type LineUnpacker s = Int -> (Int, PngLine s) -> ST s () + +type StrideInfo = (Int, Int) + +type BeginOffset = (Int, Int) + + +-- | Unpack lines where bit depth is 8 +byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, maxIdx) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount + inner pixelIndex | pixelIndex > pixelToRead = return () + | otherwise = do + let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft + destSampleIndex = destPixelIndex * sampleCount + srcPixelIndex = pixelIndex * sampleCount + beginIdx + perPixel sample | sample >= sampleCount = return () + | otherwise = do + val <- line `M.unsafeRead` (srcPixelIndex + sample) + let writeIdx = destSampleIndex + sample + (arr `M.unsafeWrite` writeIdx) val + perPixel (sample + 1) + perPixel 0 + inner (pixelIndex + 1) + inner 0 + + +-- | Unpack lines where bit depth is 1 +bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8 + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line `M.unsafeRead` (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft + forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1) + + when (lineRest /= 0) + (do val <- line `M.unsafeRead` endLine + let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft + forM_ [0 .. lineRest - 1] $ \bit -> + (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1)) + + +-- | Unpack lines when bit depth is 2 +twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4 + + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line `M.unsafeRead` (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft + (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3 + (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3 + (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3 + (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3 + + when (lineRest /= 0) + (do val <- line `M.unsafeRead` endLine + let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft + forM_ [0 .. lineRest - 1] $ \bit -> + (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3)) + +halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s +halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, endLine) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth + subPadd | subImageRest > 0 = 1 + | otherwise = 0 + (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2 + forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do + val <- line `M.unsafeRead` (pixelIndex + beginIdx) + let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft + (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF + (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF + + when (lineRest /= 0) + (do val <- line `M.unsafeRead` endLine + let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft + (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF) + +shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s +shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) + (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do + (_, maxIdx) <- getBounds line + let realTop = beginTop + h * strideHeight + lineIndex = realTop * imgWidth + pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2) + forM_ [0 .. pixelToRead] $ \pixelIndex -> do + let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft + destSampleIndex = destPixelIndex * sampleCount + srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx + forM_ [0 .. sampleCount - 1] $ \sample -> do + highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0) + lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) + let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) + writeIdx = destSampleIndex + sample + (arr `M.unsafeWrite` writeIdx) $ fullValue + +-- | Transform a scanline to a bunch of bytes. Bytes are then packed +-- into pixels at a further step. +scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset + -> LineUnpacker s +scanlineUnpacker8 1 = bitUnpacker +scanlineUnpacker8 2 = twoBitsUnpacker +scanlineUnpacker8 4 = halfByteUnpacker +scanlineUnpacker8 8 = byteUnpacker +scanlineUnpacker8 _ = error "Impossible bit depth" + +byteSizeOfBitLength :: Int -> Int -> Int -> Int +byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0) + where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8 + +scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) + -> B.ByteString + -> ST s () +scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = + pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return () + where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth + strideInfo | depth < 8 = 1 + | otherwise = sampleCount * (depth `div` 8) + +-- | Given data and image size, recreate an image with deinterlaced +-- data for PNG's adam 7 method. +adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) + -> B.ByteString -> ST s () +adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = + foldM_ (\i f -> f i) 0 subImages >> return () + where Adam7MatrixInfo { adam7StartingRow = startRows + , adam7RowIncrement = rowIncrement + , adam7StartingCol = startCols + , adam7ColIncrement = colIncrement } = adam7MatrixInfo + + subImages = + [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str + | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement + , let passWidth = sizer imgWidth beginW incrW + passHeight = sizer imgHeight beginH incrH + byteWidth = byteSizeOfBitLength depth sampleCount passWidth + ] + strideInfo | depth < 8 = 1 + | otherwise = sampleCount * (depth `div` 8) + sizer dimension begin increment + | dimension <= begin = 0 + | otherwise = outDim + (if restDim /= 0 then 1 else 0) + where (outDim, restDim) = (dimension - begin) `quotRem` increment + +-- | deinterlace picture in function of the method indicated +-- in the iHDR +deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16)) +deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind + , interlaceMethod = method, bitDepth = depth }) str = do + let compCount = sampleCountOfImageType imgKind + arraySize = fromIntegral $ w * h * compCount + deinterlaceFunction = case method of + PngNoInterlace -> scanLineInterleaving + PngInterlaceAdam7 -> adam7Unpack + iBitDepth = fromIntegral depth + if iBitDepth <= 8 + then do + imgArray <- M.new arraySize + let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray + deinterlaceFunction iBitDepth + (fromIntegral compCount) + (fromIntegral w, fromIntegral h) + (scanlineUnpacker8 iBitDepth (fromIntegral compCount) + mutableImage) + str + Left <$> V.unsafeFreeze imgArray + + else do + imgArray <- M.new arraySize + let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray + deinterlaceFunction iBitDepth + (fromIntegral compCount) + (fromIntegral w, fromIntegral h) + (shortUnpacker (fromIntegral compCount) mutableImage) + str + Right <$> V.unsafeFreeze imgArray + +generateGreyscalePalette :: Word8 -> PngPalette +generateGreyscalePalette times = Image possibilities 0 vec + where possibilities = 2 ^ times - 1 + vec = V.fromListN ((fromIntegral possibilities + 1) * 3) $ concat pixels + pixels = [[i, i, i] | n <- [0 .. possibilities] + , let i = fromIntegral $ n * (255 `div` possibilities)] + +sampleCountOfImageType :: PngImageType -> Word32 +sampleCountOfImageType PngGreyscale = 1 +sampleCountOfImageType PngTrueColour = 3 +sampleCountOfImageType PngIndexedColor = 1 +sampleCountOfImageType PngGreyscaleWithAlpha = 2 +sampleCountOfImageType PngTrueColourWithAlpha = 4 + +paletteRGBA1, paletteRGBA2, paletteRGBA4 :: PngPalette +paletteRGBA1 = generateGreyscalePalette 1 +paletteRGBA2 = generateGreyscalePalette 2 +paletteRGBA4 = generateGreyscalePalette 4 + +{-# INLINE bounds #-} +bounds :: Storable a => V.Vector a -> (Int, Int) +bounds v = (0, V.length v - 1) + +applyPalette :: PngPalette -> V.Vector Word8 -> V.Vector Word8 +applyPalette pal img = V.fromListN ((initSize + 1) * 3) pixels + where (_, initSize) = bounds img + pixels = concat [[r, g, b] | ipx <- V.toList img + , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] + +applyPaletteWithTransparency :: PngPalette -> Word8 -> V.Vector Word8 -> V.Vector Word8 +applyPaletteWithTransparency pal transp img = V.fromListN ((initSize + 1) * 4) pixels + where (_, initSize) = bounds img + pixels = concat [ if ipx == transp then [0, 0, 0, 0] else [r, g, b, 255] + | ipx <- V.toList img + , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] + +-- | Transform a raw png image to an image, without modifying the +-- underlying pixel type. If the image is greyscale and < 8 bits, +-- a transformation to RGBA8 is performed. This should change +-- in the future. +-- The resulting image let you manage the pixel types. +-- +-- This function can output the following pixel types : +-- +-- * PixelY8 +-- +-- * PixelY16 +-- +-- * PixelYA8 +-- +-- * PixelYA16 +-- +-- * PixelRGB8 +-- +-- * PixelRGB16 +-- +-- * PixelRGBA8 +-- +-- * PixelRGBA16 +-- +decodePng :: B.ByteString -> Either String DynamicImage +decodePng byte = do + rawImg <- runGetStrict get byte + let ihdr@(PngIHdr { width = w, height = h }) = header rawImg + compressedImageData = + Lb.concat [chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == iDATSignature] + zlibHeaderSize = 1 {- compression method/flags code -} + + 1 {- Additional flags/check bits -} + + 4 {-CRC-} + + toImage const1 _const2 (Left a) = + Right . const1 $ Image (fromIntegral w) (fromIntegral h) a + toImage _const1 const2 (Right a) = + Right . const2 $ Image (fromIntegral w) (fromIntegral h) a + + palette8 palette [(Lb.uncons -> Just (c,_))] (Left img) = + Right . ImageRGBA8 + . Image (fromIntegral w) (fromIntegral h) + $ applyPaletteWithTransparency palette c img + + palette8 palette _ (Left img) = + Right . ImageRGB8 + . Image (fromIntegral w) (fromIntegral h) + $ applyPalette palette img + + palette8 _ _ (Right _) = Left "Invalid bit depth for paleted image" + + transparencyColor = + [ chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == tRNSSignature ] + + unparse _ t PngGreyscale bytes + | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) t PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) t PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) t PngIndexedColor bytes + | otherwise = toImage ImageY8 ImageY16 $ runST stArray + where stArray = deinterlacer ihdr bytes + + unparse Nothing _ PngIndexedColor _ = Left "no valid palette found" + unparse _ _ PngTrueColour bytes = + toImage ImageRGB8 ImageRGB16 $ runST stArray + where stArray = deinterlacer ihdr bytes + unparse _ _ PngGreyscaleWithAlpha bytes = + toImage ImageYA8 ImageYA16 $ runST stArray + where stArray = deinterlacer ihdr bytes + unparse _ _ PngTrueColourWithAlpha bytes = + toImage ImageRGBA8 ImageRGBA16 $ runST stArray + where stArray = deinterlacer ihdr bytes + unparse (Just plte) transparency PngIndexedColor bytes = + palette8 plte transparency $ runST stArray + where stArray = deinterlacer ihdr bytes + + if Lb.length compressedImageData <= zlibHeaderSize + then Left "Invalid data size" + else let imgData = Z.decompress compressedImageData + parseableData = B.concat $ Lb.toChunks imgData + palette = case find (\c -> pLTESignature == chunkType c) $ chunks rawImg of + Nothing -> Nothing + Just p -> case parsePalette p of + Left _ -> Nothing + Right plte -> Just plte + in unparse palette transparencyColor (colourType ihdr) parseableData + diff --git a/src/Codec/Picture/Png/Export.hs b/src/Codec/Picture/Png/Export.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Export.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module implementing a basic png export, no filtering is applyed, but +-- export at least valid images. +module Codec.Picture.Png.Export( PngSavable( .. ) + , writePng + , encodeDynamicPng + , writeDynamicPng + , encodePalettedPng + ) where + +import Control.Monad( forM_ ) +import Control.Monad.ST( ST, runST ) +import Data.Bits( unsafeShiftR, (.&.) ) +import Data.Binary( encode ) +import Data.Word(Word8, Word16) +import qualified Codec.Compression.Zlib as Z +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb + +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.Png.Type +import Codec.Picture.VectorByteConversion( blitVector, toByteString ) + +-- | Encode an image into a png if possible. +class PngSavable a where + -- | Transform an image into a png encoded bytestring, ready + -- to be written as a file. + encodePng :: Image a -> Lb.ByteString + +preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr +preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr + { width = fromIntegral w + , height = fromIntegral h + , bitDepth = depth + , colourType = imgType + , compressionMethod = 0 + , filterMethod = 0 + , interlaceMethod = PngNoInterlace + } + +-- | Helper function to directly write an image as a png on disk. +writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () +writePng path img = Lb.writeFile path $ encodePng img + +endChunk :: PngRawChunk +endChunk = PngRawChunk { chunkLength = 0 + , chunkType = iENDSignature + , chunkCRC = pngComputeCrc [iENDSignature] + , chunkData = Lb.empty + } + + +prepareIDatChunk :: Lb.ByteString -> PngRawChunk +prepareIDatChunk imgData = PngRawChunk + { chunkLength = fromIntegral $ Lb.length imgData + , chunkType = iDATSignature + , chunkCRC = pngComputeCrc [iDATSignature, imgData] + , chunkData = imgData + } + +genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) + => PngImageType -> Image px -> Lb.ByteString +genericEncode16BitsPng imgKind + image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = + encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]} + where hdr = preparePngHeader image imgKind 16 + zero = B.singleton 0 + compCount = componentCount (undefined :: px) + + lineSize = compCount * w + blitToByteString vec = blitVector vec 0 (lineSize * 2) + encodeLine line = blitToByteString $ runST $ do + finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) + let baseIndex = line * lineSize + forM_ [0 .. lineSize - 1] $ \ix -> do + let v = arr `VS.unsafeIndex` (baseIndex + ix) + high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF + low = fromIntegral $ v .&. 0xFF + + (finalVec `M.unsafeWrite` (ix * 2 + 0)) high + (finalVec `M.unsafeWrite` (ix * 2 + 1)) low + + VS.unsafeFreeze finalVec + + imgEncodedData = Z.compress . Lb.fromChunks + $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] + +preparePalette :: Palette -> PngRawChunk +preparePalette pal = PngRawChunk + { chunkLength = fromIntegral $ imageWidth pal * 3 + , chunkType = pLTESignature + , chunkCRC = pngComputeCrc [pLTESignature, binaryData] + , chunkData = binaryData + } + where binaryData = Lb.fromChunks [toByteString $ imageData pal] + +genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) + => Maybe Palette -> PngImageType -> Image px + -> Lb.ByteString +genericEncodePng palette imgKind + image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = + encode PngRawImage { header = hdr + , chunks = prependPalette palette [prepareIDatChunk imgEncodedData, endChunk]} + where hdr = preparePngHeader image imgKind 8 + zero = B.singleton 0 + compCount = componentCount (undefined :: px) + + prependPalette Nothing l = l + prependPalette (Just p) l = preparePalette p : l + + lineSize = compCount * w + encodeLine line = blitVector arr (line * lineSize) lineSize + imgEncodedData = Z.compress . Lb.fromChunks + $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] + +instance PngSavable PixelRGBA8 where + encodePng = genericEncodePng Nothing PngTrueColourWithAlpha + +instance PngSavable PixelRGB8 where + encodePng = genericEncodePng Nothing PngTrueColour + +instance PngSavable Pixel8 where + encodePng = genericEncodePng Nothing PngGreyscale + +instance PngSavable PixelYA8 where + encodePng = genericEncodePng Nothing PngGreyscaleWithAlpha + +instance PngSavable PixelYA16 where + encodePng = genericEncode16BitsPng PngGreyscaleWithAlpha + +instance PngSavable Pixel16 where + encodePng = genericEncode16BitsPng PngGreyscale + +instance PngSavable PixelRGB16 where + encodePng = genericEncode16BitsPng PngTrueColour + +instance PngSavable PixelRGBA16 where + encodePng = genericEncode16BitsPng PngTrueColourWithAlpha + +-- | Write a dynamic image in a .png image file if possible. +-- The same restriction as encodeDynamicPng apply. +writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) +writeDynamicPng path img = case encodeDynamicPng img of + Left err -> return $ Left err + Right b -> Lb.writeFile path b >> return (Right True) + +-- | Encode a paletted image as a color indexed 8-bit PNG. +-- the palette must have between 1 and 256 values in it. +encodePalettedPng :: Palette -> Image Pixel8 -> Either String Lb.ByteString +encodePalettedPng pal img + | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" + | VS.any isTooBig $ imageData img = + Left "Image contains indexes absent from the palette" + | otherwise = Right $ genericEncodePng (Just pal) PngIndexedColor img + where w = imageWidth pal + h = imageHeight pal + isTooBig v = fromIntegral v >= w + +-- | Encode a dynamic image in bmp if possible, supported pixel type are : +-- +-- - Y8 +-- +-- - Y16 +-- +-- - YA8 +-- +-- - YA16 +-- +-- - RGB8 +-- +-- - RGB16 +-- +-- - RGBA8 +-- +-- - RGBA16 +-- +encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString +encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img +encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img +encodeDynamicPng (ImageY8 img) = Right $ encodePng img +encodeDynamicPng (ImageY16 img) = Right $ encodePng img +encodeDynamicPng (ImageYA8 img) = Right $ encodePng img +encodeDynamicPng (ImageYA16 img) = Right $ encodePng img +encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img +encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img +encodeDynamicPng _ = Left "Unsupported image format for PNG export" diff --git a/src/Codec/Picture/Png/Type.hs b/src/Codec/Picture/Png/Type.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Type.hs @@ -0,0 +1,329 @@ +-- | Low level png module, you should import 'Codec.Picture.Png' instead. +module Codec.Picture.Png.Type( PngIHdr( .. ) + , PngFilter( .. ) + , PngInterlaceMethod( .. ) + , PngPalette + , PngImageType( .. ) + , parsePalette + , pngComputeCrc + , pLTESignature + , iDATSignature + , iENDSignature + , tRNSSignature + -- * Low level types + , ChunkSignature + , PngRawImage( .. ) + , PngChunk( .. ) + , PngRawChunk( .. ) + , PngLowLevel( .. ) + ) where + +import Control.Applicative( (<$>) ) +import Control.Monad( when, replicateM ) +import Data.Bits( xor, (.&.), unsafeShiftR ) +import Data.Binary( Binary(..), Get, get ) +import Data.Binary.Get( getWord8 + , getWord32be + , getLazyByteString + ) +import Data.Binary.Put( runPut + , putWord8 + , putWord32be + , putLazyByteString + ) +import Data.Vector.Unboxed( Vector, fromListN, (!) ) +import qualified Data.Vector.Storable as V +import Data.List( foldl' ) +import Data.Word( Word32, Word8 ) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LS + +import Codec.Picture.Types +import Codec.Picture.InternalHelper + +-------------------------------------------------- +---- Types +-------------------------------------------------- + +-- | Value used to identify a png chunk, must be 4 bytes long. +type ChunkSignature = L.ByteString + +-- | Generic header used in PNG images. +data PngIHdr = PngIHdr + { width :: Word32 -- ^ Image width in number of pixel + , height :: Word32 -- ^ Image height in number of pixel + , bitDepth :: Word8 -- ^ Number of bit per sample + , colourType :: PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) + , compressionMethod :: Word8 -- ^ Compression method used + , filterMethod :: Word8 -- ^ Must be 0 + , interlaceMethod :: PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) + } + deriving Show + +-- | What kind of information is encoded in the IDAT section +-- of the PngFile +data PngImageType = + PngGreyscale + | PngTrueColour + | PngIndexedColor + | PngGreyscaleWithAlpha + | PngTrueColourWithAlpha + deriving Show + +-- | Raw parsed image which need to be decoded. +data PngRawImage = PngRawImage + { header :: PngIHdr + , chunks :: [PngRawChunk] + } + +-- | Palette with indices beginning at 0 to elemcount - 1 +type PngPalette = Image PixelRGB8 + +-- | Parse a palette from a png chunk. +parsePalette :: PngRawChunk -> Either String PngPalette +parsePalette plte + | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" + | otherwise = Image pixelCount 1 . V.fromListN (3 * pixelCount) <$> pixels + where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get + pixelCount = fromIntegral $ chunkLength plte `div` 3 + pixels = runGet pixelUnpacker (chunkData plte) + +-- | Data structure during real png loading/parsing +data PngRawChunk = PngRawChunk + { chunkLength :: Word32 + , chunkType :: ChunkSignature + , chunkCRC :: Word32 + , chunkData :: L.ByteString + } + +-- | PNG chunk representing some extra information found in the parsed file. +data PngChunk = PngChunk + { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk + , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. + } + +-- | Low level access to PNG information +data PngLowLevel a = PngLowLevel + { pngImage :: Image a -- ^ The real uncompressed image + , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. + } + +-- | The pixels value should be : +-- +---+---+ +-- | c | b | +-- +---+---+ +-- | a | x | +-- +---+---+ +-- x being the current filtered pixel +data PngFilter = + -- | Filt(x) = Orig(x), Recon(x) = Filt(x) + FilterNone + -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) + | FilterSub + -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) + | FilterUp + -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), + -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) + | FilterAverage + -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), + -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) + | FilterPaeth + deriving (Enum, Show) + +-- | Different known interlace methods for PNG image +data PngInterlaceMethod = + -- | No interlacing, basic data ordering, line by line + -- from left to right. + PngNoInterlace + + -- | Use the Adam7 ordering, see `adam7Reordering` + | PngInterlaceAdam7 + deriving (Enum, Show) + +-------------------------------------------------- +---- Instances +-------------------------------------------------- +instance Binary PngFilter where + put = putWord8 . toEnum . fromEnum + get = getWord8 >>= \w -> case w of + 0 -> return FilterNone + 1 -> return FilterSub + 2 -> return FilterUp + 3 -> return FilterAverage + 4 -> return FilterPaeth + _ -> fail "Invalid scanline filter" + +instance Binary PngRawImage where + put img = do + putLazyByteString pngSignature + put $ header img + mapM_ put $ chunks img + + get = parseRawPngImage + +instance Binary PngRawChunk where + put chunk = do + putWord32be $ chunkLength chunk + putLazyByteString $ chunkType chunk + when (chunkLength chunk /= 0) + (putLazyByteString $ chunkData chunk) + putWord32be $ chunkCRC chunk + + get = do + size <- getWord32be + chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature) + imgData <- if size == 0 + then return L.empty + else getLazyByteString (fromIntegral size) + crc <- getWord32be + + let computedCrc = pngComputeCrc [chunkSig, imgData] + when (computedCrc `xor` crc /= 0) + (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " + ++ show crc) + return PngRawChunk { + chunkLength = size, + chunkData = imgData, + chunkCRC = crc, + chunkType = chunkSig + } + +instance Binary PngIHdr where + put hdr = do + putWord32be 13 + let inner = runPut $ do + putLazyByteString iHDRSignature + putWord32be $ width hdr + putWord32be $ height hdr + putWord8 $ bitDepth hdr + put $ colourType hdr + put $ compressionMethod hdr + put $ filterMethod hdr + put $ interlaceMethod hdr + crc = pngComputeCrc [inner] + putLazyByteString inner + putWord32be crc + + get = do + _size <- getWord32be + ihdrSig <- getLazyByteString (L.length iHDRSignature) + when (ihdrSig /= iHDRSignature) + (fail "Invalid PNG file, wrong ihdr") + w <- getWord32be + h <- getWord32be + depth <- get + colorType <- get + compression <- get + filtermethod <- get + interlace <- get + _crc <- getWord32be + return PngIHdr { + width = w, + height = h, + bitDepth = depth, + colourType = colorType, + compressionMethod = compression, + filterMethod = filtermethod, + interlaceMethod = interlace + } + +-- | Parse method for a png chunk, without decompression. +parseChunks :: Get [PngRawChunk] +parseChunks = do + chunk <- get + + if chunkType chunk == iENDSignature + then return [chunk] + else (chunk:) <$> parseChunks + + +instance Binary PngInterlaceMethod where + get = getWord8 >>= \w -> case w of + 0 -> return PngNoInterlace + 1 -> return PngInterlaceAdam7 + _ -> fail "Invalid interlace method" + + put PngNoInterlace = putWord8 0 + put PngInterlaceAdam7 = putWord8 1 + +-- | Implementation of the get method for the PngRawImage, +-- unpack raw data, without decompressing it. +parseRawPngImage :: Get PngRawImage +parseRawPngImage = do + sig <- getLazyByteString (L.length pngSignature) + when (sig /= pngSignature) + (fail "Invalid PNG file, signature broken") + + ihdr <- get + + chunkList <- parseChunks + return PngRawImage { header = ihdr, chunks = chunkList } + +-------------------------------------------------- +---- functions +-------------------------------------------------- + +-- | Signature signalling that the following data will be a png image +-- in the png bit stream +pngSignature :: ChunkSignature +pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] + +-- | Helper function to help pack signatures. +signature :: String -> ChunkSignature +signature = LS.pack + +-- | Signature for the header chunk of png (must be the first) +iHDRSignature :: ChunkSignature +iHDRSignature = signature "IHDR" + +-- | Signature for a palette chunk in the pgn file. Must +-- occure before iDAT. +pLTESignature :: ChunkSignature +pLTESignature = signature "PLTE" + +-- | Signature for a data chuck (with image parts in it) +iDATSignature :: ChunkSignature +iDATSignature = signature "IDAT" + +-- | Signature for the last chunk of a png image, telling +-- the end. +iENDSignature :: ChunkSignature +iENDSignature = signature "IEND" + +tRNSSignature :: ChunkSignature +tRNSSignature = signature "tRNS" + +instance Binary PngImageType where + put PngGreyscale = putWord8 0 + put PngTrueColour = putWord8 2 + put PngIndexedColor = putWord8 3 + put PngGreyscaleWithAlpha = putWord8 4 + put PngTrueColourWithAlpha = putWord8 6 + + get = get >>= imageTypeOfCode + +imageTypeOfCode :: Word8 -> Get PngImageType +imageTypeOfCode 0 = return PngGreyscale +imageTypeOfCode 2 = return PngTrueColour +imageTypeOfCode 3 = return PngIndexedColor +imageTypeOfCode 4 = return PngGreyscaleWithAlpha +imageTypeOfCode 6 = return PngTrueColourWithAlpha +imageTypeOfCode _ = fail "Invalid png color code" + +-- | From the Annex D of the png specification. +pngCrcTable :: Vector Word32 +pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] + where zero = 0 :: Int -- To avoid defaulting to Integer + updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1) + | otherwise = c `unsafeShiftR` 1 + magicConstant = 0xedb88320 :: Word32 + +-- | Compute the CRC of a raw buffer, as described in annex D of the PNG +-- specification. +pngComputeCrc :: [L.ByteString] -> Word32 +pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat + where updateCrc crc val = + let u32Val = fromIntegral val + lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) + in lutVal `xor` (crc `unsafeShiftR` 8) + diff --git a/src/Codec/Picture/Saving.hs b/src/Codec/Picture/Saving.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Saving.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE TypeFamilies #-} +-- | Helper functions to save dynamic images to other file format +-- with automatic color space/sample format conversion done automatically. +module Codec.Picture.Saving( imageToJpg + , imageToPng + , imageToGif + , imageToBitmap + , imageToTiff + , imageToRadiance + ) where + +import Data.Bits( unsafeShiftR ) +import Data.Word( Word8, Word16 ) +import qualified Data.ByteString.Lazy as L +import Codec.Picture.Bitmap +import Codec.Picture.Jpg +import Codec.Picture.Png +import Codec.Picture.Gif +import Codec.Picture.ColorQuant +import Codec.Picture.HDR +import Codec.Picture.Types +import Codec.Picture.Tiff + +import qualified Data.Vector.Storable as V + +componentToLDR :: Float -> Word8 +componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 + +toStandardDef :: Image PixelRGBF -> Image PixelRGB8 +toStandardDef img = pixelMap pixelConverter img + where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b + where r = componentToLDR rf + g = componentToLDR gf + b = componentToLDR bf + +greyScaleToStandardDef :: Image PixelF -> Image Pixel8 +greyScaleToStandardDef = pixelMap componentToLDR + +from16to8 :: ( PixelBaseComponent source ~ Word16 + , PixelBaseComponent dest ~ Word8 ) + => Image source -> Image dest +from16to8 Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral (v `unsafeShiftR` 8) + +from16toFloat :: ( PixelBaseComponent source ~ Word16 + , PixelBaseComponent dest ~ Float ) + => Image source -> Image dest +from16toFloat Image { imageWidth = w, imageHeight = h + , imageData = arr } = Image w h transformed + where transformed = V.map toWord8 arr + toWord8 v = fromIntegral v / 65536.0 + +-- | This function will try to do anything to encode an image +-- as RADIANCE, make all color conversion and such. Equivalent +-- of 'decodeImage' for radiance encoding +imageToRadiance :: DynamicImage -> L.ByteString +imageToRadiance (ImageCMYK8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageCMYK16 img) = + imageToRadiance . ImageRGB16 $ convertImage img +imageToRadiance (ImageYCbCr8 img) = + imageToRadiance . ImageRGB8 $ convertImage img +imageToRadiance (ImageRGB8 img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageRGBF img) = encodeHDR img +imageToRadiance (ImageRGBA8 img) = + imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY8 img) = + imageToRadiance . ImageRGB8 $ promoteImage img +imageToRadiance (ImageYF img) = + imageToRadiance . ImageRGBF $ promoteImage img +imageToRadiance (ImageYA8 img) = + imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img +imageToRadiance (ImageY16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf v = PixelRGBF val val val + where val = fromIntegral v / 65536.0 + +imageToRadiance (ImageYA16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf (PixelYA16 v _) = PixelRGBF val val val + where val = fromIntegral v / 65536.0 +imageToRadiance (ImageRGB16 img) = + imageToRadiance . ImageRGBF $ from16toFloat img +imageToRadiance (ImageRGBA16 img) = + imageToRadiance . ImageRGBF $ pixelMap toRgbf img + where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) + where f v = fromIntegral v / 65536.0 + +-- | This function will try to do anything to encode an image +-- as JPEG, make all color conversion and such. Equivalent +-- of 'decodeImage' for jpeg encoding +imageToJpg :: Int -> DynamicImage -> L.ByteString +imageToJpg quality dynImage = + let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) + in case dynImage of + ImageYCbCr8 img -> encodeAtQuality img + ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img + ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img + ImageRGB8 img -> encodeAtQuality (convertImage img) + ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img + ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) + ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img + ImageY8 img -> encodeAtQuality . convertImage + $ (promoteImage img :: Image PixelRGB8) + ImageYA8 img -> encodeAtQuality $ + convertImage (promoteImage $ dropAlphaLayer img :: Image PixelRGB8) + ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img + ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img + ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img + ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img + +-- | This function will try to do anything to encode an image +-- as PNG, make all color conversion and such. Equivalent +-- of 'decodeImage' for PNG encoding +imageToPng :: DynamicImage -> L.ByteString +imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) +imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) +imageToPng (ImageRGB8 img) = encodePng img +imageToPng (ImageRGBF img) = encodePng $ toStandardDef img +imageToPng (ImageRGBA8 img) = encodePng img +imageToPng (ImageY8 img) = encodePng img +imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img +imageToPng (ImageYA8 img) = encodePng img +imageToPng (ImageY16 img) = encodePng img +imageToPng (ImageYA16 img) = encodePng img +imageToPng (ImageRGB16 img) = encodePng img +imageToPng (ImageRGBA16 img) = encodePng img + +-- | This function will try to do anything to encode an image +-- as a Tiff, make all color conversion and such. Equivalent +-- of 'decodeImage' for Tiff encoding +imageToTiff :: DynamicImage -> L.ByteString +imageToTiff (ImageYCbCr8 img) = encodeTiff img +imageToTiff (ImageCMYK8 img) = encodeTiff img +imageToTiff (ImageCMYK16 img) = encodeTiff img +imageToTiff (ImageRGB8 img) = encodeTiff img +imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img +imageToTiff (ImageRGBA8 img) = encodeTiff img +imageToTiff (ImageY8 img) = encodeTiff img +imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img +imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img +imageToTiff (ImageY16 img) = encodeTiff img +imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img +imageToTiff (ImageRGB16 img) = encodeTiff img +imageToTiff (ImageRGBA16 img) = encodeTiff img + +-- | This function will try to do anything to encode an image +-- as bitmap, make all color conversion and such. Equivalent +-- of 'decodeImage' for Bitmap encoding +imageToBitmap :: DynamicImage -> L.ByteString +imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) +imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img +imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img +imageToBitmap (ImageRGB8 img) = encodeBitmap img +imageToBitmap (ImageRGBA8 img) = encodeBitmap img +imageToBitmap (ImageY8 img) = encodeBitmap img +imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img +imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) +imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img +imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img +imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img +imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img + + +-- | This function will try to do anything to encode an image +-- as a gif, make all color conversion and quantization. Equivalent +-- of 'decodeImage' for gif encoding +imageToGif :: DynamicImage -> Either String L.ByteString +imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img +imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img +imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img +imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal + where (indexed, pal) = palettize defaultPaletteOptions img +imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img +imageToGif (ImageY8 img) = Right $ encodeGifImage img +imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img +imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img +imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 img +imageToGif (ImageYA16 img) = imageToGif . ImageYA8 $ from16to8 img +imageToGif (ImageRGB16 img) = imageToGif . ImageRGB8 $ from16to8 img +imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tiff.hs @@ -0,0 +1,1285 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | Module implementing TIFF decoding. +-- +-- Supported compression schemes : +-- +-- * Uncompressed +-- +-- * PackBits +-- +-- * LZW +-- +-- Supported bit depth : +-- +-- * 2 bits +-- +-- * 4 bits +-- +-- * 8 bits +-- +-- * 16 bits +-- +module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where + +import Control.Applicative( (<$>), (<*>), pure ) +import Control.Monad( when, replicateM, foldM_ ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.Writer.Strict( execWriter, tell, Writer ) +import Data.Int( Int8 ) +import Data.Word( Word8, Word16 ) +import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord16le, getWord16be + , getWord32le, getWord32be + , bytesRead + , skip + , getByteString + ) +import Data.Binary.Put( Put, runPut + , putWord16le, putWord16be + , putWord32le, putWord32be + , putByteString + ) + +import Data.List( sortBy, mapAccumL ) +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Storable.Mutable as M +import Data.Word( Word32 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as BU + +import Foreign.Storable( sizeOf ) + +import Codec.Picture.InternalHelper +import Codec.Picture.BitWriter +import Codec.Picture.Types +import Codec.Picture.Gif.LZW +import Codec.Picture.VectorByteConversion( toByteString ) + +data Endianness = EndianLittle + | EndianBig + deriving (Eq, Show) + +instance Binary Endianness where + put EndianLittle = putWord16le 0x4949 + put EndianBig = putWord16le 0x4D4D + + get = do + tag <- getWord16le + case tag of + 0x4949 -> return EndianLittle + 0x4D4D -> return EndianBig + _ -> fail "Invalid endian tag value" + +-- | Because having a polymorphic get with endianness is to nice +-- to pass on, introducing this helper type class, which is just +-- a superset of Binary, but formalising a parameter passing +-- into it. +class BinaryParam a b where + getP :: a -> Get b + putP :: a -> b -> Put + +data TiffHeader = TiffHeader + { hdrEndianness :: !Endianness + , hdrOffset :: {-# UNPACK #-} !Word32 + } + deriving (Eq, Show) + +instance BinaryParam Endianness Word16 where + putP EndianLittle = putWord16le + putP EndianBig = putWord16be + + getP EndianLittle = getWord16le + getP EndianBig = getWord16be + +instance BinaryParam Endianness Word32 where + putP EndianLittle = putWord32le + putP EndianBig = putWord32be + + getP EndianLittle = getWord32le + getP EndianBig = getWord32be + +instance Binary TiffHeader where + put hdr = do + let endian = hdrEndianness hdr + put endian + putP endian (42 :: Word16) + putP endian $ hdrOffset hdr + + get = do + endian <- get + magic <- getP endian + let magicValue = 42 :: Word16 + when (magic /= magicValue) + (fail "Invalid TIFF magic number") + TiffHeader endian <$> getP endian + +data TiffPlanarConfiguration = + PlanarConfigContig -- = 1 + | PlanarConfigSeparate -- = 2 + +planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration +planarConfgOfConstant 0 = pure PlanarConfigContig +planarConfgOfConstant 1 = pure PlanarConfigContig +planarConfgOfConstant 2 = pure PlanarConfigSeparate +planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" + +constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 +constantToPlaneConfiguration PlanarConfigContig = 1 +constantToPlaneConfiguration PlanarConfigSeparate = 2 + +data TiffCompression = + CompressionNone -- 1 + | CompressionModifiedRLE -- 2 + | CompressionLZW -- 5 + | CompressionJPEG -- 6 + | CompressionPackBit -- 32273 + +data IfdType = TypeByte + | TypeAscii + | TypeShort + | TypeLong + | TypeRational + | TypeSByte + | TypeUndefined + | TypeSignedShort + | TypeSignedLong + | TypeSignedRational + | TypeFloat + | TypeDouble + +instance BinaryParam Endianness IfdType where + getP endianness = getP endianness >>= conv + where + conv :: Word16 -> Get IfdType + conv 1 = return TypeByte + conv 2 = return TypeAscii + conv 3 = return TypeShort + conv 4 = return TypeLong + conv 5 = return TypeRational + conv 6 = return TypeSByte + conv 7 = return TypeUndefined + conv 8 = return TypeSignedShort + conv 9 = return TypeSignedLong + conv 10 = return TypeSignedRational + conv 11 = return TypeFloat + conv 12 = return TypeDouble + conv _ = fail "Invalid TIF directory type" + + putP endianness = putP endianness . conv + where + conv :: IfdType -> Word16 + conv TypeByte = 1 + conv TypeAscii = 2 + conv TypeShort = 3 + conv TypeLong = 4 + conv TypeRational = 5 + conv TypeSByte = 6 + conv TypeUndefined = 7 + conv TypeSignedShort = 8 + conv TypeSignedLong = 9 + conv TypeSignedRational = 10 + conv TypeFloat = 11 + conv TypeDouble = 12 + +data TiffTag = TagPhotometricInterpretation + | TagCompression -- ^ Short type + | TagImageWidth -- ^ Short or long type + | TagImageLength -- ^ Short or long type + | TagXResolution -- ^ Rational type + | TagYResolution -- ^ Rational type + | TagResolutionUnit -- ^ Short type + | TagRowPerStrip -- ^ Short or long type + | TagStripByteCounts -- ^ Short or long + | TagStripOffsets -- ^ Short or long + | TagBitsPerSample -- ^ Short + | TagColorMap -- ^ Short + | TagTileWidth + | TagTileLength + | TagTileOffset + | TagTileByteCount + | TagSamplesPerPixel -- ^ Short + | TagArtist + | TagDocumentName + | TagSoftware + | TagPlanarConfiguration -- ^ Short + | TagOrientation + | TagSampleFormat -- ^ Short + | TagInkSet + | TagSubfileType + | TagFillOrder + | TagYCbCrCoeff + | TagYCbCrSubsampling + | TagYCbCrPositioning + | TagReferenceBlackWhite + | TagXPosition + | TagYPosition + | TagExtraSample + | TagImageDescription + + | TagJpegProc + | TagJPEGInterchangeFormat + | TagJPEGInterchangeFormatLength + | TagJPEGRestartInterval + | TagJPEGLosslessPredictors + | TagJPEGPointTransforms + | TagJPEGQTables + | TagJPEGDCTables + | TagJPEGACTables + + | TagUnknown Word16 + deriving (Eq, Show) + +tagOfWord16 :: Word16 -> TiffTag +tagOfWord16 = aux + where aux 255 = TagSubfileType + aux 256 = TagImageWidth + aux 257 = TagImageLength + aux 258 = TagBitsPerSample + aux 259 = TagCompression + aux 262 = TagPhotometricInterpretation + aux 266 = TagFillOrder + aux 269 = TagDocumentName + aux 270 = TagImageDescription + aux 273 = TagStripOffsets + aux 274 = TagOrientation + aux 277 = TagSamplesPerPixel + aux 278 = TagRowPerStrip + aux 279 = TagStripByteCounts + aux 282 = TagXResolution + aux 283 = TagYResolution + aux 284 = TagPlanarConfiguration + aux 286 = TagXPosition + aux 287 = TagYPosition + aux 296 = TagResolutionUnit + aux 305 = TagSoftware + aux 315 = TagArtist + aux 320 = TagColorMap + aux 322 = TagTileWidth + aux 323 = TagTileLength + aux 324 = TagTileOffset + aux 325 = TagTileByteCount + aux 332 = TagInkSet + aux 338 = TagExtraSample + aux 339 = TagSampleFormat + aux 529 = TagYCbCrCoeff + aux 512 = TagJpegProc + aux 513 = TagJPEGInterchangeFormat + aux 514 = TagJPEGInterchangeFormatLength + aux 515 = TagJPEGRestartInterval + aux 517 = TagJPEGLosslessPredictors + aux 518 = TagJPEGPointTransforms + aux 519 = TagJPEGQTables + aux 520 = TagJPEGDCTables + aux 521 = TagJPEGACTables + aux 530 = TagYCbCrSubsampling + aux 531 = TagYCbCrPositioning + aux 532 = TagReferenceBlackWhite + aux v = TagUnknown v + +word16OfTag :: TiffTag -> Word16 +word16OfTag = aux + where aux TagSubfileType = 255 + aux TagImageWidth = 256 + aux TagImageLength = 257 + aux TagBitsPerSample = 258 + aux TagCompression = 259 + aux TagPhotometricInterpretation = 262 + aux TagFillOrder = 266 + aux TagDocumentName = 269 + aux TagImageDescription = 270 + aux TagStripOffsets = 273 + aux TagOrientation = 274 + aux TagSamplesPerPixel = 277 + aux TagRowPerStrip = 278 + aux TagStripByteCounts = 279 + aux TagXResolution = 282 + aux TagYResolution = 283 + aux TagPlanarConfiguration = 284 + aux TagXPosition = 286 + aux TagYPosition = 287 + aux TagResolutionUnit = 296 + aux TagSoftware = 305 + aux TagArtist = 315 + aux TagColorMap = 320 + aux TagTileWidth = 322 + aux TagTileLength = 323 + aux TagTileOffset = 324 + aux TagTileByteCount = 325 + aux TagInkSet = 332 + aux TagExtraSample = 338 + aux TagSampleFormat = 339 + aux TagYCbCrCoeff = 529 + aux TagJpegProc = 512 + aux TagJPEGInterchangeFormat = 513 + aux TagJPEGInterchangeFormatLength = 514 + aux TagJPEGRestartInterval = 515 + aux TagJPEGLosslessPredictors = 517 + aux TagJPEGPointTransforms = 518 + aux TagJPEGQTables = 519 + aux TagJPEGDCTables = 520 + aux TagJPEGACTables = 521 + aux TagYCbCrSubsampling = 530 + aux TagYCbCrPositioning = 531 + aux TagReferenceBlackWhite = 532 + aux (TagUnknown v) = v + +instance BinaryParam Endianness TiffTag where + getP endianness = tagOfWord16 <$> getP endianness + putP endianness = putP endianness . word16OfTag + +data ExtendedDirectoryData = + ExtendedDataNone + | ExtendedDataAscii !B.ByteString + | ExtendedDataShort !(V.Vector Word16) + | ExtendedDataLong !(V.Vector Word32) + deriving (Eq, Show) + +instance BinaryParam (Endianness, ImageFileDirectory) ExtendedDirectoryData where + putP (endianness, _) = dump + where + dump ExtendedDataNone = pure () + dump (ExtendedDataAscii bstr) = putByteString bstr + dump (ExtendedDataShort shorts) = V.mapM_ (putP endianness) shorts + dump (ExtendedDataLong longs) = V.mapM_ (putP endianness) longs + + getP (endianness, ifd) = fetcher ifd + where + align ImageFileDirectory { ifdOffset = offset } = do + readed <- bytesRead + skip . fromIntegral $ fromIntegral offset - readed + + getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + getVec count = V.replicateM (fromIntegral count) + + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = + align ifd >> (ExtendedDataAscii <$> getByteString (fromIntegral count)) + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = + pure . ExtendedDataShort $ V.fromListN 2 valList + where high = fromIntegral $ ofs `unsafeShiftR` 16 + low = fromIntegral $ ofs .&. 0xFFFF + valList = case endianness of + EndianLittle -> [low, high] + EndianBig -> [high, low] + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = + align ifd >> (ExtendedDataShort <$> getVec count getE) + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = + align ifd >> (ExtendedDataLong <$> getVec count getE) + fetcher _ = pure ExtendedDataNone + +data TiffSampleFormat = + TiffSampleUint + | TiffSampleInt + | TiffSampleDouble + | TiffSampleUnknown + deriving Eq + +unpackSampleFormat :: Word32 -> Get TiffSampleFormat +unpackSampleFormat = aux + where + aux 1 = pure TiffSampleUint + aux 2 = pure TiffSampleInt + aux 3 = pure TiffSampleDouble + aux 4 = pure TiffSampleUnknown + aux v = fail $ "Undefined data format (" ++ show v ++ ")" + +data ImageFileDirectory = ImageFileDirectory + { ifdIdentifier :: !TiffTag + , ifdType :: !IfdType + , ifdCount :: !Word32 + , ifdOffset :: !Word32 + , ifdExtended :: !ExtendedDirectoryData + } + +unLong :: String -> ExtendedDirectoryData -> Get (V.Vector Word32) +unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v +unLong _ (ExtendedDataLong v) = pure v +unLong errMessage _ = fail errMessage + +cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory +cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd + where aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } + aux _ = ifd +cleanImageFileDirectory _ ifd = ifd + +instance BinaryParam Endianness ImageFileDirectory where + getP endianness = + ImageFileDirectory <$> getE <*> getE <*> getE <*> getE + <*> pure ExtendedDataNone + where getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + putP endianness ifd =do + let putE :: (BinaryParam Endianness a) => a -> Put + putE = putP endianness + putE $ ifdIdentifier ifd + putE $ ifdType ifd + putE $ ifdCount ifd + putE $ ifdOffset ifd + +instance BinaryParam Endianness [ImageFileDirectory] where + getP endianness = do + count <- getP endianness :: Get Word16 + rez <- replicateM (fromIntegral count) $ getP endianness + _ <- getP endianness :: Get Word32 + pure rez + + putP endianness lst = do + let count = fromIntegral $ length lst :: Word16 + putP endianness count + mapM_ (putP endianness) lst + putP endianness (0 :: Word32) + +fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory] +fetchExtended endian = mapM $ \ifd -> do + v <- getP (endian, ifd) + pure $ ifd { ifdExtended = v } + +findIFD :: String -> TiffTag -> [ImageFileDirectory] + -> Get ImageFileDirectory +findIFD errorMessage tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> fail errorMessage + (x:_) -> pure x + +findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16)) +findPalette ifds = + case [v | v <- ifds, ifdIdentifier v == TagColorMap] of + (ImageFileDirectory { ifdExtended = ExtendedDataShort vec }:_) -> + pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx + where pixelCount = V.length vec `div` 3 + axx v = vec `V.unsafeIndex` (idx + color * pixelCount) + where (idx, color) = v `divMod` 3 + + _ -> pure Nothing + +findIFDData :: String -> TiffTag -> [ImageFileDirectory] -> Get Word32 +findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst + +findIFDDefaultData :: Word32 -> TiffTag -> [ImageFileDirectory] -> Get Word32 +findIFDDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (x:_) -> pure $ ifdOffset x + +findIFDExt :: String -> TiffTag -> [ImageFileDirectory] -> Get ExtendedDirectoryData +findIFDExt msg tag lst = do + val <- findIFD msg tag lst + case val of + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> + pure . ExtendedDataShort . V.singleton $ fromIntegral ofs + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> + pure . ExtendedDataLong . V.singleton $ fromIntegral ofs + ImageFileDirectory { ifdExtended = v } -> pure v + + +findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] + -> Get [Word32] +findIFDExtDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (ImageFileDirectory { ifdExtended = ExtendedDataNone }:_) -> return d + (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x) + where errorMessage = + "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x) + +-- It's temporary, remove once tiff decoding is better +-- handled. +{- +instance Show (Image PixelRGB16) where + show _ = "Image PixelRGB16" +-} + +data TiffInfo = TiffInfo + { tiffHeader :: TiffHeader + , tiffWidth :: Word32 + , tiffHeight :: Word32 + , tiffColorspace :: TiffColorspace + , tiffSampleCount :: Word32 + , tiffRowPerStrip :: Word32 + , tiffPlaneConfiguration :: TiffPlanarConfiguration + , tiffSampleFormat :: [TiffSampleFormat] + , tiffBitsPerSample :: V.Vector Word32 + , tiffCompression :: TiffCompression + , tiffStripSize :: V.Vector Word32 + , tiffOffsets :: V.Vector Word32 + , tiffPalette :: Maybe (Image PixelRGB16) + , tiffYCbCrSubsampling :: V.Vector Word32 + } + +data TiffColorspace = + TiffMonochromeWhite0 -- ^ 0 + | TiffMonochrome -- ^ 1 + | TiffRGB -- ^ 2 + | TiffPaleted -- ^ 3 + | TiffTransparencyMask -- ^ 4 + | TiffCMYK -- ^ 5 + | TiffYCbCr -- ^ 6 + | TiffCIELab -- ^ 8 + +packPhotometricInterpretation :: TiffColorspace -> Word16 +packPhotometricInterpretation = aux + where + aux TiffMonochromeWhite0 = 0 + aux TiffMonochrome = 1 + aux TiffRGB = 2 + aux TiffPaleted = 3 + aux TiffTransparencyMask = 4 + aux TiffCMYK = 5 + aux TiffYCbCr = 6 + aux TiffCIELab = 8 + +unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace +unpackPhotometricInterpretation = aux + where aux 0 = pure TiffMonochromeWhite0 + aux 1 = pure TiffMonochrome + aux 2 = pure TiffRGB + aux 3 = pure TiffPaleted + aux 4 = pure TiffTransparencyMask + aux 5 = pure TiffCMYK + aux 6 = pure TiffYCbCr + aux 8 = pure TiffCIELab + aux v = fail $ "Unrecognized color space " ++ show v + +unPackCompression :: Word32 -> Get TiffCompression +unPackCompression = aux + where + aux 0 = pure CompressionNone + aux 1 = pure CompressionNone + aux 2 = pure CompressionModifiedRLE + aux 5 = pure CompressionLZW + aux 6 = pure CompressionJPEG + aux 32773 = pure CompressionPackBit + aux v = fail $ "Unknown compression scheme " ++ show v + +packCompression :: TiffCompression -> Word16 +packCompression = aux + where + aux CompressionNone = 1 + aux CompressionModifiedRLE = 2 + aux CompressionLZW = 5 + aux CompressionJPEG = 6 + aux CompressionPackBit = 32773 + +copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) + -> ST s Int +copyByteString str vec stride startWrite (from, count) = inner startWrite fromi + where fromi = fromIntegral from + maxi = fromi + fromIntegral count + + inner writeIdx i | i >= maxi = pure writeIdx + inner writeIdx i = do + let v = str `BU.unsafeIndex` i + (vec `M.unsafeWrite` writeIdx) v + inner (writeIdx + stride) $ i + 1 + +unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int + -> (Word32, Word32) + -> ST s Int +unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex + where fromi = fromIntegral offset + maxi = fromi + fromIntegral size + + replicateByte writeIdx _ 0 = pure writeIdx + replicateByte writeIdx v count = do + (outVec `M.unsafeWrite` writeIdx) v + replicateByte (writeIdx + stride) v $ count - 1 + + loop i writeIdx | i >= maxi = pure writeIdx + loop i writeIdx = choice + {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-} + where v = fromIntegral (str `B.index` i) :: Int8 + + choice + -- data + | 0 <= v = do + copyByteString str outVec stride writeIdx + (fromIntegral $ i + 1, fromIntegral v + 1) + >>= loop (i + 2 + fromIntegral v) + -- run + | -127 <= v = do + {-let nextByte = str `BU.unsafeIndex` (i + 1)-} + let nextByte = str `B.index` (i + 1) + count = negate (fromIntegral v) + 1 :: Int + replicateByte writeIdx nextByte count + >>= loop (i + 2) + + -- noop + | otherwise = loop writeIdx $ i + 1 + +uncompressAt :: TiffCompression + -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) + -> ST s Int +uncompressAt CompressionNone = copyByteString +uncompressAt CompressionPackBit = unpackPackBit +uncompressAt CompressionLZW = \str outVec _stride writeIndex (offset, size) -> do + let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str + runBoolReader $ decodeLzwTiff toDecode outVec writeIndex + return 0 +uncompressAt _ = error "Unhandled compression" + +class Unpackable a where + type StorageType a :: * + + outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a)) + + -- | Final image and size, return offset and vector + allocTempBuffer :: a -> M.STVector s (StorageType a) -> Int + -> ST s (M.STVector s Word8) + + offsetStride :: a -> Int -> Int -> (Int, Int) + + mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker. + -> Endianness + -> M.STVector s Word8 -- ^ Temporary buffer handling decompression. + -> Int -- ^ Line size in pixels + -> Int -- ^ Write index, in bytes + -> Word32 -- ^ size, in bytes + -> Int -- ^ Stride + -> M.STVector s (StorageType a) -- ^ Final buffer + -> ST s () + +-- | The Word8 instance is just a passthrough, to avoid +-- copying memory twice +instance Unpackable Word8 where + type StorageType Word8 = Word8 + + offsetStride _ i stride = (i, stride) + allocTempBuffer _ buff _ = pure buff + mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure () + outAlloc _ count = M.replicate count 0 -- M.new + +instance Unpackable Word16 where + type StorageType Word16 = Word16 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 2 + mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = + looperLe index 0 + where looperLe _ readIndex | readIndex >= fromIntegral size = pure () + looperLe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + let finalValue = + (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1 + (outVec `M.write` writeIndex) finalValue + + looperLe (writeIndex + stride) (readIndex + 2) + mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = + looperBe index 0 + where looperBe _ readIndex | readIndex >= fromIntegral size = pure () + looperBe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + let finalValue = + (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2 + (outVec `M.write` writeIndex) finalValue + + looperBe (writeIndex + stride) (readIndex + 2) + +instance Unpackable Word32 where + type StorageType Word32 = Word32 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ s = M.new $ s * 4 + mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = + looperLe index 0 + where looperLe _ readIndex | readIndex >= fromIntegral size = pure () + looperLe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + v3 <- tempVec `M.read` (readIndex + 2) + v4 <- tempVec `M.read` (readIndex + 3) + let finalValue = + (fromIntegral v4 `unsafeShiftL` 24) .|. + (fromIntegral v3 `unsafeShiftL` 16) .|. + (fromIntegral v2 `unsafeShiftL` 8) .|. + fromIntegral v1 + (outVec `M.write` writeIndex) finalValue + + looperLe (writeIndex + stride) (readIndex + 4) + mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = + looperBe index 0 + where looperBe _ readIndex | readIndex >= fromIntegral size = pure () + looperBe writeIndex readIndex = do + v1 <- tempVec `M.read` readIndex + v2 <- tempVec `M.read` (readIndex + 1) + v3 <- tempVec `M.read` (readIndex + 2) + v4 <- tempVec `M.read` (readIndex + 3) + let finalValue = + (fromIntegral v1 `unsafeShiftL` 24) .|. + (fromIntegral v2 `unsafeShiftL` 16) .|. + (fromIntegral v3 `unsafeShiftL` 8) .|. + fromIntegral v4 + (outVec `M.write` writeIndex) finalValue + + looperBe (writeIndex + stride) (readIndex + 4) + +data Pack4 = Pack4 + +instance Unpackable Pack4 where + type StorageType Pack4 = Word8 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v <- tempVec `M.read` readIdx + let high = (v `unsafeShiftR` 4) .&. 0xF + low = v .&. 0xF + (outVec `M.write` writeIdx) high + when (writeIdx + stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) low + + inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2) + +data Pack2 = Pack2 + +instance Unpackable Pack2 where + type StorageType Pack2 = Word8 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v <- tempVec `M.read` readIdx + let v0 = (v `unsafeShiftR` 6) .&. 0x3 + v1 = (v `unsafeShiftR` 4) .&. 0x3 + v2 = (v `unsafeShiftR` 2) .&. 0x3 + v3 = v .&. 0x3 + + (outVec `M.write` writeIdx) v0 + when (writeIdx + 1 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) v1 + + when (writeIdx + 2 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride * 2)) v2 + + when (writeIdx + 3 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride * 3)) v3 + + inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4) + +data Pack12 = Pack12 + +instance Unpackable Pack12 where + type StorageType Pack12 = Word16 + allocTempBuffer _ _ = M.new + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = + inner 0 index pxCount + where pxCount = lineSize `div` stride + + maxWrite = M.length outVec + inner readIdx writeIdx _ + | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () + inner readIdx writeIdx line + | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount + inner readIdx writeIdx line = do + v0 <- tempVec `M.read` readIdx + v1 <- if readIdx + 1 < fromIntegral size + then tempVec `M.read` (readIdx + 1) + else pure 0 + v2 <- if readIdx + 2 < fromIntegral size + then tempVec `M.read` (readIdx + 2) + else pure 0 + + let high0 = fromIntegral v0 `unsafeShiftL` 4 + low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF + + p0 = high0 .|. low0 + + high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8 + low1 = fromIntegral v2 + p1 = high1 .|. low1 + + (outVec `M.write` writeIdx) p0 + when (writeIdx + 1 * stride < maxWrite) $ + (outVec `M.write` (writeIdx + stride)) p1 + + inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2) + +data YCbCrSubsampling = YCbCrSubsampling + { ycbcrWidth :: !Int + , ycbcrHeight :: !Int + , ycbcrImageWidth :: !Int + , ycbcrStripHeight :: !Int + } + +instance Unpackable YCbCrSubsampling where + type StorageType YCbCrSubsampling = Word8 + + offsetStride _ _ _ = (0, 1) + outAlloc _ = M.new + allocTempBuffer _ _ = M.new + mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec = + foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1] + , bx <- [0, w .. imgWidth - 1]] + where w = ycbcrWidth subSampling + h = ycbcrHeight subSampling + imgWidth = ycbcrImageWidth subSampling + lineCount = ycbcrStripHeight subSampling + + lumaCount = w * h + blockSize = lumaCount + 2 + + maxOut = M.length outVec + + unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx + unpacker readIdx (bx, by) = do + cb <- tempVec `M.read` (readIdx + lumaCount) + cr <- tempVec `M.read` (readIdx + lumaCount + 1) + + let pixelIndices = + [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]] + + writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex + writer readIndex writeIdx = do + y <- tempVec `M.read` readIndex + (outVec `M.write` writeIdx) y + (outVec `M.write` (writeIdx + 1)) cb + (outVec `M.write` (writeIdx + 2)) cr + return $ readIndex + 1 + + foldM_ writer readIdx pixelIndices + + return $ readIdx + blockSize + +gatherStrips :: ( Unpackable comp + , Pixel pixel + , StorageType comp ~ PixelBaseComponent pixel + ) + => comp -> B.ByteString -> TiffInfo -> Image pixel +gatherStrips comp str nfo = runST $ do + let width = fromIntegral $ tiffWidth nfo + height = fromIntegral $ tiffHeight nfo + sampleCount = if tiffSampleCount nfo /= 0 + then fromIntegral $ tiffSampleCount nfo + else V.length $ tiffBitsPerSample nfo + + rowPerStrip = fromIntegral $ tiffRowPerStrip nfo + endianness = hdrEndianness $ tiffHeader nfo + + stripCount = V.length $ tiffOffsets nfo + compression = tiffCompression nfo + + outVec <- outAlloc comp $ width * height * sampleCount + tempVec <- allocTempBuffer comp outVec + (rowPerStrip * width * sampleCount) + + let mutableImage = MutableImage + { mutableImageWidth = fromIntegral width + , mutableImageHeight = fromIntegral height + , mutableImageData = outVec + } + + case tiffPlaneConfiguration nfo of + PlanarConfigContig -> V.mapM_ unpacker sizes + where unpacker (idx, offset, size) = do + let (writeIdx, tempStride) = offsetStride comp idx 1 + _ <- uncompressAt compression str tempVec tempStride + writeIdx (offset, size) + mergeBackTempBuffer comp endianness tempVec (width * sampleCount) + idx size 1 outVec + + startWriteOffset = + V.generate stripCount(width * rowPerStrip * sampleCount *) + + sizes = V.zip3 startWriteOffset (tiffOffsets nfo) (tiffStripSize nfo) + + PlanarConfigSeparate -> V.mapM_ unpacker sizes + where unpacker (idx, offset, size) = do + let (writeIdx, tempStride) = offsetStride comp idx stride + _ <- uncompressAt compression str tempVec tempStride + writeIdx (offset, size) + mergeBackTempBuffer comp endianness tempVec (width * sampleCount) + idx size stride outVec + + stride = V.length $ tiffOffsets nfo + idxVector = V.enumFromN 0 stride + sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo) + + unsafeFreezeImage mutableImage + +ifdSingleLong :: TiffTag -> Word32 -> Writer [ImageFileDirectory] () +ifdSingleLong tag = ifdMultiLong tag . V.singleton + +ifdSingleShort :: Endianness -> TiffTag -> Word16 + -> Writer [ImageFileDirectory] () +ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral + +ifdMultiLong :: TiffTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () +ifdMultiLong tag v = tell . pure $ ImageFileDirectory + { ifdIdentifier = tag + , ifdType = TypeLong + , ifdCount = fromIntegral $ V.length v + , ifdOffset = offset + , ifdExtended = extended + } + where (offset, extended) + | V.length v > 1 = (0, ExtendedDataLong v) + | otherwise = (V.head v, ExtendedDataNone) + +ifdMultiShort :: Endianness -> TiffTag -> V.Vector Word32 + -> Writer [ImageFileDirectory] () +ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory + { ifdIdentifier = tag + , ifdType = TypeShort + , ifdCount = size + , ifdOffset = offset + , ifdExtended = extended + } + where size = fromIntegral $ V.length v + (offset, extended) + | size > 2 = (0, ExtendedDataShort $ V.map fromIntegral v) + | size == 2 = + let v1 = fromIntegral $ V.head v + v2 = fromIntegral $ v `V.unsafeIndex` 1 + in + case endian of + EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExtendedDataNone) + EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExtendedDataNone) + + | otherwise = case endian of + EndianLittle -> (V.head v, ExtendedDataNone) + EndianBig -> (V.head v `unsafeShiftL` 16, ExtendedDataNone) + +-- | All the IFD must be written in order according to the tag +-- value of the IFD. To avoid getting to much restriction in the +-- serialization code, just sort it. +orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] +orderIfdByTag = sortBy comparer + where comparer a b = compare t1 t2 + where t1 = word16OfTag $ ifdIdentifier a + t2 = word16OfTag $ ifdIdentifier b + +-- | Given an official offset and a list of IFD, update the offset information +-- of the IFD with extended data. +setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> [ImageFileDirectory] +setupIfdOffsets initialOffset lst = snd $ mapAccumL updater startExtended lst + where ifdElementCount = fromIntegral $ length lst + ifdSize = 12 + ifdCountSize = 2 + nextOffsetSize = 4 + startExtended = initialOffset + + ifdElementCount * ifdSize + + ifdCountSize + nextOffsetSize + + updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataAscii b }) = + (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v }) + | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) + , ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort v }) + | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) + , ifd { ifdOffset = ix }) + updater ix ifd = (ix, ifd) + +instance BinaryParam B.ByteString TiffInfo where + putP rawData nfo = do + put $ tiffHeader nfo + + let ifdStartOffset = hdrOffset $ tiffHeader nfo + endianness = hdrEndianness $ tiffHeader nfo + + ifdShort = ifdSingleShort endianness + ifdShorts = ifdMultiShort endianness + list = setupIfdOffsets ifdStartOffset . orderIfdByTag . execWriter $ do + ifdSingleLong TagImageWidth $ tiffWidth nfo + ifdSingleLong TagImageLength $ tiffHeight nfo + ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo + ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo + ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo + ifdShort TagPhotometricInterpretation + . packPhotometricInterpretation + $ tiffColorspace nfo + ifdShort TagPlanarConfiguration + . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo + ifdShort TagCompression . packCompression + $ tiffCompression nfo + ifdMultiLong TagStripOffsets $ tiffOffsets nfo + + ifdMultiLong TagStripByteCounts $ tiffStripSize nfo + + let subSampling = tiffYCbCrSubsampling nfo + when (not $ V.null subSampling) $ + ifdShorts TagYCbCrSubsampling subSampling + + putByteString rawData + putP endianness list + mapM_ (\ifd -> putP (endianness, ifd) $ ifdExtended ifd) list + + getP _ = do + hdr <- get + readed <- bytesRead + skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed + let endian = hdrEndianness hdr + + ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian + cleaned <- fetchExtended endian ifd + + let dataFind str tag = findIFDData str tag cleaned + dataDefault def tag = findIFDDefaultData def tag cleaned + extFind str tag = findIFDExt str tag cleaned + extDefault def tag = findIFDExtDefaultData def tag cleaned + + TiffInfo hdr + <$> dataFind "Can't find width" TagImageWidth + <*> dataFind "Can't find height" TagImageLength + <*> (dataFind "Can't find color space" TagPhotometricInterpretation + >>= unpackPhotometricInterpretation) + <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel + <*> dataFind "Can't find row per strip" TagRowPerStrip + <*> (dataDefault 1 TagPlanarConfiguration + >>= planarConfgOfConstant) + <*> (extDefault [1] TagSampleFormat + >>= mapM unpackSampleFormat) + <*> (extFind "Can't find bit per sample" TagBitsPerSample + >>= unLong "Can't find bit depth") + <*> (dataFind "Can't find Compression" TagCompression + >>= unPackCompression) + <*> (extFind "Can't find byte counts" TagStripByteCounts + >>= unLong "Can't find bit per sample") + <*> (extFind "Strip offsets missing" TagStripOffsets + >>= unLong "Can't find strip offsets") + <*> findPalette cleaned + <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) + +unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage +-- | while mandatory some images don't put correct +-- rowperstrip. So replacing 0 with actual image height. +unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = + unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo } +unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted + , tiffBitsPerSample = lst + , tiffSampleFormat = format + , tiffPalette = Just p + } + | lst == V.singleton 8 && format == [TiffSampleUint] = + let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) + gathered :: Image Pixel8 + gathered = gatherStrips (0 :: Word8) file nfo + in + pure . ImageRGB16 $ applyPalette gathered + + | lst == V.singleton 4 && format == [TiffSampleUint] = + let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) + gathered :: Image Pixel8 + gathered = gatherStrips Pack4 file nfo + in + pure . ImageRGB16 $ applyPalette gathered + + | lst == V.singleton 2 && format == [TiffSampleUint] = + let applyPalette = pixelMap (\v -> pixelAt p (fromIntegral v) 0) + gathered :: Image Pixel8 + gathered = gatherStrips Pack2 file nfo + in + pure . ImageRGB16 $ applyPalette gathered + +unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = + pure . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo + + | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = + pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo + +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } + | otherwise = do + img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) + case img of + ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i + ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i + _ -> pure img + +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.singleton 2 && all (TiffSampleUint ==) format = + pure . ImageY8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo + | lst == V.singleton 4 && all (TiffSampleUint ==) format = + pure . ImageY8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo + | lst == V.singleton 8 && all (TiffSampleUint ==) format = + pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.singleton 12 && all (TiffSampleUint ==) format = + pure . ImageY16 . pixelMap (16 *) $ gatherStrips Pack12 file nfo + | lst == V.singleton 16 && all (TiffSampleUint ==) format = + pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo + | lst == V.singleton 32 && all (TiffSampleUint ==) format = + pure . ImageY16 $ pixelMap (toWord16) img + where toWord16 v = fromIntegral $ v `unsafeShiftR` 16 + img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + +unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr + , tiffBitsPerSample = lst + , tiffPlaneConfiguration = PlanarConfigContig + , tiffSampleFormat = format } + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . ImageYCbCr8 $ gatherStrips cbcrConf file nfo + where defaulting 0 = 2 + defaulting n = n + + w = defaulting $ tiffYCbCrSubsampling nfo V.! 0 + h = defaulting $ tiffYCbCrSubsampling nfo V.! 1 + cbcrConf = YCbCrSubsampling + { ycbcrWidth = fromIntegral w + , ycbcrHeight = fromIntegral h + , ycbcrImageWidth = fromIntegral $ tiffWidth nfo + , ycbcrStripHeight = fromIntegral $ tiffRowPerStrip nfo + } + +unpack file nfo@TiffInfo { tiffColorspace = TiffRGB + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = + pure . ImageRGB8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = + pure . ImageRGB8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = + pure . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = + pure . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo + | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = + pure . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + -- some files are a little bit borked... + | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = + pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo + +unpack _ _ = fail "Failure to unpack TIFF file" + +-- | Transform a raw tiff image to an image, without modifying +-- the underlying pixel type. +-- +-- This function can output the following pixel types : +-- +-- * PixelY8 +-- +-- * PixelY16 +-- +-- * PixelRGB8 +-- +-- * PixelRGB16 +-- +-- * PixelCMYK8 +-- +-- * PixelCMYK16 +-- +decodeTiff :: B.ByteString -> Either String DynamicImage +decodeTiff file = runGetStrict (getP file) file >>= unpack file + +-- | Class defining which pixel types can be serialized in a +-- Tiff file. +class (Pixel px) => TiffSaveable px where + colorSpaceOfPixel :: px -> TiffColorspace + + subSamplingInfo :: px -> V.Vector Word32 + subSamplingInfo _ = V.empty + +instance TiffSaveable Pixel8 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable Pixel16 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable PixelCMYK8 where + colorSpaceOfPixel _ = TiffCMYK + +instance TiffSaveable PixelCMYK16 where + colorSpaceOfPixel _ = TiffCMYK + +instance TiffSaveable PixelRGB8 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelRGB16 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelRGBA8 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelRGBA16 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelYCbCr8 where + colorSpaceOfPixel _ = TiffYCbCr + subSamplingInfo _ = V.fromListN 2 [1, 1] + +-- | Transform an image into a Tiff encoded bytestring, reade to be +-- written as a file. +encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString +encodeTiff img = runPut $ putP rawPixelData hdr + where intSampleCount = componentCount (undefined :: px) + sampleCount = fromIntegral intSampleCount + + sampleType = (undefined :: PixelBaseComponent px) + pixelData = imageData img + + rawPixelData = toByteString pixelData + width = fromIntegral $ imageWidth img + height = fromIntegral $ imageHeight img + intSampleSize = sizeOf sampleType + sampleSize = fromIntegral intSampleSize + bitPerSample = sampleSize * 8 + imageSize = width * height * sampleCount * sampleSize + headerSize = 8 + + hdr = TiffInfo + { tiffHeader = TiffHeader + { hdrEndianness = EndianLittle + , hdrOffset = headerSize + imageSize + } + , tiffWidth = width + , tiffHeight = height + , tiffColorspace = colorSpaceOfPixel (undefined :: px) + , tiffSampleCount = fromIntegral $ sampleCount + , tiffRowPerStrip = fromIntegral $ imageHeight img + , tiffPlaneConfiguration = PlanarConfigContig + , tiffSampleFormat = [TiffSampleUint] + , tiffBitsPerSample = V.replicate intSampleCount bitPerSample + , tiffCompression = CompressionNone + , tiffStripSize = V.singleton imageSize + , tiffOffsets = V.singleton headerSize + , tiffPalette = Nothing + , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) + } + +-- | Helper function to directly write an image as a tiff on disk. +writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO () +writeTiff path img = Lb.writeFile path $ encodeTiff img + diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Types.hs @@ -0,0 +1,1837 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +-- | 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 + -- ** Image types + Image( .. ) + , MutableImage( .. ) + , DynamicImage( .. ) + , Palette + + -- ** Image functions + , createMutableImage + , freezeImage + , unsafeFreezeImage + , thawImage + , unsafeThawImage + + -- ** Pixel types + , Pixel8 + , Pixel16 + , Pixel32 + , PixelF + , PixelYA8( .. ) + , PixelYA16( .. ) + , PixelRGB8( .. ) + , PixelRGB16( .. ) + , PixelRGBF( .. ) + , PixelRGBA8( .. ) + , PixelRGBA16( .. ) + , PixelCMYK8( .. ) + , PixelCMYK16( .. ) + , PixelYCbCr8( .. ) + + -- * Type classes + , ColorConvertible( .. ) + , Pixel(..) + -- $graph + , ColorSpaceConvertible( .. ) + , LumaPlaneExtractable( .. ) + , TransparentPixel( .. ) + + -- * Helper functions + , pixelMap + , pixelMapXY + , pixelFold + , dynamicMap + , dynamicPixelMap + , dropAlphaLayer + , withImage + , zipPixelComponent3 + , generateImage + , generateFoldImage + , gammaCorrection + , toneMapping + + -- * Color plane extraction + , ColorPlane ( ) + + , PlaneRed( .. ) + , PlaneGreen( .. ) + , PlaneBlue( .. ) + , PlaneAlpha( .. ) + , PlaneLuma( .. ) + , PlaneCr( .. ) + , PlaneCb( .. ) + , PlaneCyan( .. ) + , PlaneMagenta( .. ) + , PlaneYellow( .. ) + , PlaneBlack( .. ) + + , extractComponent + , unsafeExtractComponent + ) where + +import Control.Monad( forM_, foldM, liftM, ap ) +import Control.DeepSeq( NFData( .. ) ) +import Control.Monad.ST( runST ) +import Control.Monad.Primitive ( PrimMonad, PrimState ) +import Foreign.Storable ( Storable ) +import Data.Bits( unsafeShiftL, unsafeShiftR ) +import Data.Word( Word8, Word16, Word32 ) +import Data.List( foldl' ) +import Data.Vector.Storable ( (!) ) +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +#include "ConvGraph.hs" + +-- | 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. +data Image a = Image + { -- | Width of the image in pixels + imageWidth :: {-# UNPACK #-} !Int + -- | Height of the image in pixels. + , imageHeight :: {-# UNPACK #-} !Int + + -- | The real image, to extract pixels at some position + -- you should use the helpers functions. + , imageData :: V.Vector (PixelBaseComponent a) + } + +-- | Type for the palette used in Gif & PNG files. +type Palette = Image PixelRGB8 + +{-# INLINE (!!!) #-} +(!!!) :: (Storable e) => V.Vector e -> Int -> e +(!!!) = V.unsafeIndex + +-- | Class used to describle plane present in the pixel +-- type. If a pixel has a plane description associated, +-- you can use the plane name to extract planes independently. +class ColorPlane pixel planeToken where + -- | Retrieve the index of the component in the + -- given pixel type. + toComponentIndex :: pixel -> planeToken -> Int + +-- | Define the plane for the red color component +data PlaneRed = PlaneRed + +-- | Define the plane for the green color component +data PlaneGreen = PlaneGreen + +-- | Define the plane for the blue color component +data PlaneBlue = PlaneBlue + +-- | Define the plane for the alpha (transparency) component +data PlaneAlpha = PlaneAlpha + +-- | Define the plane for the luma component +data PlaneLuma = PlaneLuma + +-- | Define the plane for the Cr component +data PlaneCr = PlaneCr + +-- | Define the plane for the Cb component +data PlaneCb = PlaneCb + +-- | Define plane for the cyan component of the +-- CMYK color space. +data PlaneCyan = PlaneCyan + +-- | Define plane for the magenta component of the +-- CMYK color space. +data PlaneMagenta = PlaneMagenta + +-- | Define plane for the yellow component of the +-- CMYK color space. +data PlaneYellow = PlaneYellow + +-- | Define plane for the black component of +-- the CMYK color space. +data PlaneBlack = PlaneBlack + +-- | Extract a color plane from an image given a present plane in the image +-- examples : +-- +-- @ +-- extractRedPlane :: Image PixelRGB8-> Image Pixel8 +-- extractRedPlane = extractComponent PlaneRed +-- @ +-- +extractComponent :: forall px plane. ( Pixel px + , Pixel (PixelBaseComponent px) + , PixelBaseComponent (PixelBaseComponent px) + ~ PixelBaseComponent px + , ColorPlane px plane ) + => plane -> Image px -> Image (PixelBaseComponent px) +extractComponent plane = unsafeExtractComponent idx + where idx = toComponentIndex (undefined :: px) plane + +-- | Extract an image plane of an image, returning an image which +-- can be represented by a gray scale image. +-- If you ask a component out of bound, the `error` function will +-- be called +unsafeExtractComponent :: forall a + . ( Pixel a + , Pixel (PixelBaseComponent a) + , PixelBaseComponent (PixelBaseComponent a) + ~ PixelBaseComponent a) + => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) + -> Image a -- ^ Source image + -> Image (PixelBaseComponent a) +unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h }) + | comp >= padd = error $ "extractComponent : invalid component index (" + ++ show comp ++ ", max:" ++ show padd ++ ")" + | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } + where plane = stride img 1 padd comp + padd = componentCount (undefined :: a) + +-- | 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 + + -- | access the transparency (alpha layer) of a given + -- transparent pixel type + getTransparency :: a -> PixelBaseComponent a + +instance TransparentPixel PixelRGBA8 PixelRGB8 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b + {-# INLINE getTransparency #-} + getTransparency (PixelRGBA8 _ _ _ a) = a + +stride :: (Storable (PixelBaseComponent a)) + => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) +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. +data MutableImage s a = MutableImage + { -- | Width of the image in pixels + mutableImageWidth :: {-# UNPACK #-} !Int + + -- | Height of the image in pixels. + , mutableImageHeight :: {-# UNPACK #-} !Int + + -- | The real image, to extract pixels at some position + -- you should use the helpers functions. + , mutableImageData :: M.STVector s (PixelBaseComponent a) + } + +-- | `O(n)` Yield an immutable copy of an image by making a copy of it +freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m) + => MutableImage (PrimState m) px -> m (Image px) +freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d + +-- | `O(n)` Yield a mutable copy of an image by making a copy of it. +thawImage :: (Storable (PixelBaseComponent px), PrimMonad m) + => Image px -> m (MutableImage (PrimState m) px) +thawImage (Image w h d) = MutableImage w h `liftM` V.thaw d + +-- | `O(1)` Unsafe convert an imutable image to an mutable one without copying. +-- The source image shouldn't be used after this operation. +unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m) + => Image px -> m (MutableImage (PrimState m) px) +unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d + +-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. +-- The mutable image may not be used after this operation. +unsafeFreezeImage :: (Storable (PixelBaseComponent a), PrimMonad m) + => MutableImage (PrimState m) a -> m (Image a) +unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d + +-- | Create a mutable image, filled with the given background color. +createMutableImage :: (Pixel px, PrimMonad m) + => Int -- ^ Width + -> Int -- ^ Height + -> px -- ^ Background color + -> m (MutableImage (PrimState m) px) +createMutableImage width height background = + unsafeThawImage $ generateImage (\_ _ -> background) width height + +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 = + -- | A greyscale image. + ImageY8 (Image Pixel8) + -- | A greyscale image with 16bit components + | ImageY16 (Image Pixel16) + -- | A greyscale HDR image + | ImageYF (Image PixelF) + -- | An image in greyscale with an alpha channel. + | ImageYA8 (Image PixelYA8) + -- | An image in greyscale with alpha channel on 16 bits. + | ImageYA16 (Image PixelYA16) + -- | An image in true color. + | ImageRGB8 (Image PixelRGB8) + -- | An image in true color with 16bit depth. + | ImageRGB16 (Image PixelRGB16) + -- | An image with HDR pixels + | ImageRGBF (Image PixelRGBF) + -- | An image in true color and an alpha channel. + | ImageRGBA8 (Image PixelRGBA8) + -- | A true color image with alpha on 16 bits. + | ImageRGBA16 (Image PixelRGBA16) + -- | An image in the colorspace used by Jpeg images. + | ImageYCbCr8 (Image PixelYCbCr8) + -- | An image in the colorspace CMYK + | ImageCMYK8 (Image PixelCMYK8) + -- | An image in the colorspace CMYK and 16 bots precision + | ImageCMYK16 (Image PixelCMYK16) + +-- | Helper function to help extract information from dynamic +-- image. To get the width of an dynamic image, you can use +-- the following snippet : +-- +-- > dynWidth :: DynamicImage -> Int +-- > dynWidth img = dynamicMap imageWidth img +-- +dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a) + -> DynamicImage -> a +dynamicMap f (ImageY8 i) = f i +dynamicMap f (ImageY16 i) = f i +dynamicMap f (ImageYF i) = f i +dynamicMap f (ImageYA8 i) = f i +dynamicMap f (ImageYA16 i) = f i +dynamicMap f (ImageRGB8 i) = f i +dynamicMap f (ImageRGB16 i) = f i +dynamicMap f (ImageRGBF i) = f i +dynamicMap f (ImageRGBA8 i) = f i +dynamicMap f (ImageRGBA16 i) = f i +dynamicMap f (ImageYCbCr8 i) = f i +dynamicMap f (ImageCMYK8 i) = f i +dynamicMap f (ImageCMYK16 i) = f i + +-- | Equivalent of the `pixelMap` function for the dynamic images. +-- You can perform pixel colorspace independant operations with this +-- function. +-- +-- For instance, if you wan't to extract a square crop of any image, +-- without caring about colorspace, you can use the following snippet. +-- +-- > dynSquare :: DynamicImage -> DynamicImage +-- > dynSquare = dynMap squareImage +-- > +-- > squareImage :: Pixel a => Image a -> Image a +-- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge +-- > where edge = min (imageWidth img) (imageHeight img) +-- +dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel) + -> DynamicImage -> DynamicImage +dynamicPixelMap f = aux + where + aux (ImageY8 i) = ImageY8 (f i) + aux (ImageY16 i) = ImageY16 (f i) + aux (ImageYF i) = ImageYF (f i) + aux (ImageYA8 i) = ImageYA8 (f i) + aux (ImageYA16 i) = ImageYA16 (f i) + aux (ImageRGB8 i) = ImageRGB8 (f i) + aux (ImageRGB16 i) = ImageRGB16 (f i) + aux (ImageRGBF i) = ImageRGBF (f i) + aux (ImageRGBA8 i) = ImageRGBA8 (f i) + aux (ImageRGBA16 i) = ImageRGBA16 (f i) + aux (ImageYCbCr8 i) = ImageYCbCr8 (f i) + aux (ImageCMYK8 i) = ImageCMYK8 (f i) + aux (ImageCMYK16 i) = ImageCMYK16 (f i) + +instance NFData DynamicImage where + rnf (ImageY8 img) = rnf img + rnf (ImageY16 img) = rnf img + rnf (ImageYF img) = rnf img + rnf (ImageYA8 img) = rnf img + rnf (ImageYA16 img) = rnf img + rnf (ImageRGB8 img) = rnf img + rnf (ImageRGB16 img) = rnf img + rnf (ImageRGBF img) = rnf img + rnf (ImageRGBA8 img) = rnf img + rnf (ImageRGBA16 img) = rnf img + rnf (ImageYCbCr8 img) = rnf img + rnf (ImageCMYK8 img) = rnf img + rnf (ImageCMYK16 img) = rnf img + +-- | Simple alias for greyscale value in 8 bits. +type Pixel8 = Word8 + +-- | Simple alias for greyscale value in 16 bits. +type Pixel16 = Word16 + +-- | Simple alias for greyscale value in 16 bits. +type Pixel32 = Word32 + +-- | Floating greyscale value, the 0 to 255 8 bit range maps +-- to 0 to 1 in this floating version +type PixelF = Float + +-- | Pixel type storing Luminance (Y) and alpha information +-- on 8 bits. +-- Value are stored in the following order : +-- +-- * Luminance +-- +-- * Alpha +-- +data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8 -- Luminance + {-# UNPACK #-} !Pixel8 -- Alpha value + deriving (Eq, Ord, Show) + +-- | Pixel type storing Luminance (Y) and alpha information +-- on 16 bits. +-- Value are stored in the following order : +-- +-- * Luminance +-- +-- * Alpha +-- +data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16 -- Luminance + {-# UNPACK #-} !Pixel16 -- Alpha value + deriving (Eq, Ord, Show) + +-- | Pixel type storing classic pixel on 8 bits +-- Value are stored in the following order : +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red + {-# UNPACK #-} !Pixel8 -- Green + {-# UNPACK #-} !Pixel8 -- Blue + deriving (Eq, Ord, Show) + +-- | Pixel type storing pixels on 16 bits +-- Value are stored in the following order : +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red + {-# UNPACK #-} !Pixel16 -- Green + {-# UNPACK #-} !Pixel16 -- Blue + deriving (Eq, Ord, Show) + +-- | Pixel type storing HDR pixel on 32 bits float +-- Value are stored in the following order : +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red + {-# UNPACK #-} !PixelF -- Green + {-# UNPACK #-} !PixelF -- Blue + deriving (Eq, Ord, Show) + +-- | Pixel storing data in the YCbCr colorspace, +-- value are stored in the following order : +-- +-- * Y (luminance) +-- +-- * Cr +-- +-- * Cb +-- +data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance + {-# UNPACK #-} !Pixel8 -- Cr red difference + {-# UNPACK #-} !Pixel8 -- Cb blue difference + deriving (Eq, Ord, Show) + +-- | Pixel storing data in the CMYK colorspace. value +-- are stored in the following order : +-- +-- * Cyan +-- +-- * Magenta +-- +-- * Yellow +-- +-- * Black +-- +data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan + {-# UNPACK #-} !Pixel8 -- Magenta + {-# UNPACK #-} !Pixel8 -- Yellow + {-# UNPACK #-} !Pixel8 -- Black + deriving (Eq, Ord, Show) + +-- | Pixel storing data in the CMYK colorspace. value +-- are stored in the following order : +-- +-- * Cyan +-- +-- * Magenta +-- +-- * Yellow +-- +-- * Black +-- +data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan + {-# UNPACK #-} !Pixel16 -- Magenta + {-# UNPACK #-} !Pixel16 -- Yellow + {-# UNPACK #-} !Pixel16 -- Black + deriving (Eq, Ord, Show) + + +-- | Pixel type storing a classic pixel, with an alpha component. +-- Values are stored in the following order +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +-- * Alpha +-- +data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red + {-# UNPACK #-} !Pixel8 -- Green + {-# UNPACK #-} !Pixel8 -- Blue + {-# UNPACK #-} !Pixel8 -- Alpha + deriving (Eq, Ord, Show) + +-- | Pixel type storing a RGB information with an alpha +-- channel on 16 bits. +-- Values are stored in the following order +-- +-- * Red +-- +-- * Green +-- +-- * Blue +-- +-- * Alpha +-- +data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red + {-# UNPACK #-} !Pixel16 -- Green + {-# UNPACK #-} !Pixel16 -- Blue + {-# UNPACK #-} !Pixel16 -- Alpha + deriving (Eq, Ord, Show) + +-- | Definition of pixels used in images. Each pixel has a color space, and a representative +-- component (Word8 or Float). +class ( Storable (PixelBaseComponent a) + , Num (PixelBaseComponent a), Eq a ) => Pixel a where + -- | Type of the pixel component, "classical" images + -- would have Word8 type as their PixelBaseComponent, + -- HDR image would have Float for instance + type PixelBaseComponent a :: * + + -- | Call the function for every component of the pixels. + -- For example for RGB pixels mixWith is declared like this : + -- + -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = + -- > PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) + -- + mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a) + -> a -> a -> a + + -- | Return the number of component of the pixel + componentCount :: a -> Int + + -- | Apply a function to all color component of a pixel. + colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a + + -- | Calculate the index for the begining of the pixel + pixelBaseIndex :: Image a -> Int -> Int -> Int + pixelBaseIndex (Image { imageWidth = w }) x y = + (x + y * w) * componentCount (undefined :: a) + + -- | Calculate theindex for the begining of the pixel at position x y + mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int + mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = + (x + y * w) * componentCount (undefined :: a) + + -- | Extract a pixel at a given position, (x, y), the origin + -- is assumed to be at the corner top left, positive y to the + -- bottom of the image + pixelAt :: Image a -> Int -> Int -> a + + -- | Same as pixelAt but for mutable images. + readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a + + -- | Write a pixel in a mutable image at position x y + writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m () + + -- | Unsafe version of pixelAt, read a pixel at the given + -- index without bound checking (if possible). + -- The index is expressed in number (PixelBaseComponent a) + unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a + + -- | Unsafe version of readPixel, read a pixel at the given + -- position without bound checking (if possible). The index + -- is expressed in number (PixelBaseComponent a) + unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a + + -- | Unsafe version of writePixel, write a pixel at the + -- given position without bound checking. This can be _really_ unsafe. + -- The index is expressed in number (PixelBaseComponent a) + unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m () + + +-- | Implement upcasting for pixel types +-- Minimal declaration declaration `promotePixel` +-- It is strongly recommanded to overload promoteImage to keep +-- performance acceptable +class (Pixel a, Pixel b) => ColorConvertible a b where + -- | Convert a pixel type to another pixel type. This + -- operation should never loss any data. + promotePixel :: a -> b + + -- | Change the underlying pixel type of an image by performing a full copy + -- of it. + promoteImage :: Image a -> Image b + 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 = 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. +-- +-- for example, to create a small gradient image : +-- +-- > imageCreator :: String -> Image PixelRGB8 +-- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 +-- > where pixelRenderer x y = PixelRGB8 x y 128 +-- +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 lineGenerator _ y | y >= h = return () + lineGenerator lineIdx y = column lineIdx 0 + where column idx x | x >= w = lineGenerator idx $ y + 1 + column idx x = do + unsafeWritePixel arr idx $ f x y + column (idx + compCount) $ x + 1 + + lineGenerator 0 0 + V.unsafeFreeze arr + +-- | Create an image using a monadic initializer function. +-- 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. +-- +-- The function is called for each pixel in the line from left to right (0 to width - 1) +-- and for each line (0 to height - 1). +withImage :: forall m pixel. (Pixel pixel, PrimMonad m) + => Int -- ^ Image width + -> Int -- ^ Image height + -> (Int -> Int -> m pixel) -- ^ Generating functions + -> m (Image pixel) +withImage width height pixelGenerator = do + let pixelComponentCount = componentCount (undefined :: pixel) + arr <- M.new (width * height * pixelComponentCount) + let mutImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = height + , mutableImageData = arr + } + + let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]] + sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx + | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]] + unsafeFreezeImage mutImage + +-- | 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. +-- +-- the acc parameter is a user defined one. +-- +-- The function is called for each pixel in the line from left to right (0 to width - 1) +-- and for each line (0 to height - 1). +generateFoldImage :: forall a acc. (Pixel a) + => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y + -> acc -- ^ Initial state + -> Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> (acc, Image a) +generateFoldImage f intialAcc w h = + (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated }) + where compCount = componentCount (undefined :: a) + (finalState, generated) = runST $ do + arr <- M.new (w * h * compCount) + let mutImage = MutableImage { + mutableImageWidth = w, + mutableImageHeight = h, + mutableImageData = arr } + foldResult <- foldM (\acc (x,y) -> do + let (acc', px) = f acc x y + writePixel mutImage x y px + return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] + + frozen <- V.unsafeFreeze arr + return (foldResult, frozen) + +-- | Fold over the pixel of an image with a raster scan order : +-- from top to bottom, left to right +{-# INLINE pixelFold #-} +pixelFold :: (Pixel pixel) + => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc +pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = + lineFold + where pixelFolder y acc x = f acc x y $ pixelAt img x y + columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] + lineFold = foldl' columnFold initialAccumulator [0 .. h - 1] + +-- | `map` equivalent for an image, working at the pixel level. +-- Little example : a brightness function for an rgb image +-- +-- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8 +-- > brightnessRGB8 add = pixelMap brightFunction +-- > where up v = fromIntegral (fromIntegral v + add) +-- > brightFunction (PixelRGB8 r g b) = +-- > PixelRGB8 (up r) (up g) (up b) +-- +pixelMap :: forall a b. (Pixel a, Pixel b) + => (a -> b) -> Image a -> Image b +{-# RULES "pixelMap fusion" forall g f. pixelMap g . pixelMap f = pixelMap (g . f) #-} +{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} +{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} +{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} +{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} +pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = + Image w h pixels + where sourceComponentCount = componentCount (undefined :: a) + destComponentCount = componentCount (undefined :: b) + + pixels = runST $ do + newArr <- M.new (w * h * destComponentCount) + let lineMapper _ _ y | y >= h = return () + lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 + where colMapper readIdx writeIdx x + | x >= w = lineMapper readIdx writeIdx $ y + 1 + | otherwise = do + unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx + colMapper (readIdx + sourceComponentCount) + (writeIdx + destComponentCount) + (x + 1) + lineMapper 0 0 0 + + -- 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 + +-- | Just like `pixelMap` only the function takes the pixel coordinates as +-- additional parameters. +pixelMapXY :: forall a b. (Pixel a, Pixel b) + => (Int -> Int -> a -> b) -> Image a -> Image b +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelYCbCr8 -> PixelRGB8) + -> Image PixelYCbCr8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelYCbCr8) + -> Image PixelRGB8 -> Image PixelYCbCr8 #-} +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGB8) + -> Image PixelRGB8 -> Image PixelRGB8 #-} +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGBA8) + -> Image PixelRGB8 -> Image PixelRGBA8 #-} +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGBA8 -> PixelRGBA8) + -> Image PixelRGBA8 -> Image PixelRGBA8 #-} +{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> Pixel8 -> PixelRGB8) + -> Image Pixel8 -> Image PixelRGB8 #-} +pixelMapXY f Image { imageWidth = w, imageHeight = h, imageData = vec } = + Image w h pixels + where sourceComponentCount = componentCount (undefined :: a) + destComponentCount = componentCount (undefined :: b) + + pixels = runST $ do + newArr <- M.new (w * h * destComponentCount) + let lineMapper _ _ y | y >= h = return () + lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 + where colMapper readIdx writeIdx x + | x >= w = lineMapper readIdx writeIdx $ y + 1 + | otherwise = do + unsafeWritePixel newArr writeIdx . f x y $ unsafePixelAt vec readIdx + colMapper (readIdx + sourceComponentCount) + (writeIdx + destComponentCount) + (x + 1) + lineMapper 0 0 0 + + -- 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 + +-- | Combine, pixel by pixel and component by component +-- the values of 3 different images. Usage example: +-- +-- > averageBrightNess c1 c2 c3 = clamp $ toInt c1 + toInt c2 + toInt c3 +-- > where clamp = fromIntegral . min 0 . max 255 +-- > toInt :: a -> Int +-- > toInt = fromIntegral +-- > ziPixelComponent3 averageBrightNess img1 img2 img3 +-- +zipPixelComponent3 + :: forall px. ( V.Storable (PixelBaseComponent px)) + => (PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px + -> PixelBaseComponent px) + -> Image px -> Image px -> Image px -> Image px +{-# INLINE zipPixelComponent3 #-} +zipPixelComponent3 f i1@(Image { imageWidth = w, imageHeight = h }) i2 i3 + | not isDimensionEqual = error "Different image size zipPairwisePixelComponent" + | otherwise = Image { imageWidth = w + , imageHeight = h + , imageData = V.zipWith3 f data1 data2 data3 + } + where data1 = imageData i1 + data2 = imageData i2 + data3 = imageData i3 + + isDimensionEqual = + w == imageWidth i2 && w == imageWidth i3 && + h == imageHeight i2 && h == imageHeight i3 + +-- | Helper class to help extract a luma plane out +-- of an image or a pixel +class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where + -- | Compute the luminance part of a pixel + computeLuma :: a -> (PixelBaseComponent a) + + -- | Extract a luma plane out of an image. This + -- method is in the typeclass to help performant + -- implementation. + -- + -- > jpegToGrayScale :: FilePath -> FilePath -> IO () + -- > jpegToGrayScale source dest + extractLumaPlane :: Image a -> Image (PixelBaseComponent a) + extractLumaPlane = pixelMap computeLuma + +instance LumaPlaneExtractable Pixel8 where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + +instance LumaPlaneExtractable Pixel16 where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + +instance LumaPlaneExtractable Pixel32 where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + +instance LumaPlaneExtractable PixelF where + {-# INLINE computeLuma #-} + computeLuma = id + extractLumaPlane = id + +instance LumaPlaneExtractable PixelRGBF where + {-# INLINE computeLuma #-} + computeLuma (PixelRGBF r g b) = + 0.3 * r + 0.59 * g + 0.11 * 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 PixelYCbCr8 where + {-# INLINE computeLuma #-} + computeLuma (PixelYCbCr8 y _ _) = y + extractLumaPlane = extractComponent PlaneLuma + +-- | Free promotion for identic pixel types +instance (Pixel a) => ColorConvertible a a where + {-# INLINE promotePixel #-} + promotePixel = id + + {-# INLINE promoteImage #-} + promoteImage = id + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> m a +(.!!!.) = M.read -- unsafeRead + +{-# INLINE (.<-.) #-} +(.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () +(.<-.) = M.write -- unsafeWrite + +-------------------------------------------------- +---- Pixel8 instances +-------------------------------------------------- +instance Pixel Pixel8 where + type PixelBaseComponent Pixel8 = Word8 + + {-# INLINE mixWith #-} + mixWith f = f 0 + + {-# INLINE colorMap #-} + colorMap f = f + + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.read` mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.write` mutablePixelBaseIndex image x y + + unsafePixelAt = V.unsafeIndex + unsafeReadPixel = M.unsafeRead + unsafeWritePixel = M.unsafeWrite + +instance ColorConvertible Pixel8 PixelYA8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelYA8 c 255 + +instance ColorConvertible Pixel8 PixelF where + {-# INLINE promotePixel #-} + promotePixel c = fromIntegral c / 255.0 + +instance ColorConvertible Pixel8 Pixel16 where + {-# INLINE promotePixel #-} + promotePixel c = fromIntegral c `unsafeShiftL` 8 + +instance ColorConvertible Pixel8 PixelRGB8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGB8 c c c + +instance ColorConvertible Pixel8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGBA8 c c c 255 + +-------------------------------------------------- +---- Pixel16 instances +-------------------------------------------------- +instance Pixel Pixel16 where + type PixelBaseComponent Pixel16 = Word16 + + {-# INLINE mixWith #-} + mixWith f = f 0 + + {-# INLINE colorMap #-} + colorMap f = f + + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.read` mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.write` mutablePixelBaseIndex image x y + + unsafePixelAt = V.unsafeIndex + unsafeReadPixel = M.unsafeRead + unsafeWritePixel = M.unsafeWrite + +instance ColorConvertible Pixel16 PixelYA16 where + {-# INLINE promotePixel #-} + promotePixel c = PixelYA16 c maxBound + +instance ColorConvertible Pixel16 PixelRGB16 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGB16 c c c + +instance ColorConvertible Pixel16 PixelRGBA16 where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGBA16 c c c maxBound + +-------------------------------------------------- +---- Pixel32 instances +-------------------------------------------------- +instance Pixel Pixel32 where + type PixelBaseComponent Pixel32 = Word32 + + {-# INLINE mixWith #-} + mixWith f = f 0 + + {-# INLINE colorMap #-} + colorMap f = f + + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.read` mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.write` mutablePixelBaseIndex image x y + + unsafePixelAt = V.unsafeIndex + unsafeReadPixel = M.unsafeRead + unsafeWritePixel = M.unsafeWrite + +-------------------------------------------------- +---- PixelF instances +-------------------------------------------------- +instance Pixel PixelF where + type PixelBaseComponent PixelF = Float + + {-# INLINE mixWith #-} + mixWith f = f 0 + + {-# INLINE colorMap #-} + colorMap f = f + componentCount _ = 1 + pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) + + readPixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.read` mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y = + arr `M.write` mutablePixelBaseIndex image x y + + unsafePixelAt = V.unsafeIndex + unsafeReadPixel = M.unsafeRead + unsafeWritePixel = M.unsafeWrite + +instance ColorConvertible PixelF PixelRGBF where + {-# INLINE promotePixel #-} + promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59) (c / 0.11) + +-------------------------------------------------- +---- PixelYA8 instances +-------------------------------------------------- +instance Pixel PixelYA8 where + type PixelBaseComponent PixelYA8 = Word8 + + {-# INLINE mixWith #-} + mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) = + PixelYA8 (f 0 ya yb) (f 1 aa ab) + + + {-# INLINE colorMap #-} + colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a) + componentCount _ = 2 + pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr .!!!. baseIdx + av <- arr .!!!. (baseIdx + 1) + return $ PixelYA8 yv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) yv + (arr .<-. (baseIdx + 1)) av + + unsafePixelAt v idx = + PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) + unsafeReadPixel vec idx = + PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) + unsafeWritePixel v idx (PixelYA8 y a) = + M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a + +instance ColorConvertible PixelYA8 PixelRGB8 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA8 y _) = PixelRGB8 y y y + +instance ColorConvertible PixelYA8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a + +instance ColorPlane PixelYA8 PlaneLuma where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelYA8 PlaneAlpha where + toComponentIndex _ _ = 1 + +instance TransparentPixel PixelYA8 Pixel8 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelYA8 y _) = y + {-# INLINE getTransparency #-} + getTransparency (PixelYA8 _ a) = a + +instance LumaPlaneExtractable PixelYA8 where + {-# INLINE computeLuma #-} + computeLuma (PixelYA8 y _) = y + extractLumaPlane = extractComponent PlaneLuma + +-------------------------------------------------- +---- PixelYA16 instances +-------------------------------------------------- +instance Pixel PixelYA16 where + type PixelBaseComponent PixelYA16 = Word16 + + {-# INLINE mixWith #-} + mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) = + PixelYA16 (f 0 ya yb) (f 1 aa ab) + + {-# INLINE colorMap #-} + colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a) + componentCount _ = 2 + pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr .!!!. baseIdx + av <- arr .!!!. (baseIdx + 1) + return $ PixelYA16 yv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) yv + (arr .<-. (baseIdx + 1)) av + + unsafePixelAt v idx = + PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) + unsafeReadPixel vec idx = + PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) + unsafeWritePixel v idx (PixelYA16 y a) = + M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a + +instance ColorConvertible PixelYA16 PixelRGBA16 where + {-# INLINE promotePixel #-} + promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a + +instance ColorPlane PixelYA16 PlaneLuma where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelYA16 PlaneAlpha where + toComponentIndex _ _ = 1 + +instance TransparentPixel PixelYA16 Pixel16 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelYA16 y _) = y + {-# INLINE getTransparency #-} + getTransparency (PixelYA16 _ a) = a + +-------------------------------------------------- +---- PixelRGBF instances +-------------------------------------------------- +instance Pixel PixelRGBF where + type PixelBaseComponent PixelRGBF = PixelF + + {-# INLINE mixWith #-} + mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) = + PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) + + {-# INLINE colorMap #-} + colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b) + + componentCount _ = 3 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + return $ PixelRGBF rv gv bv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + + unsafePixelAt v idx = + PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) + unsafeReadPixel vec idx = + PixelRGBF `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + unsafeWritePixel v idx (PixelRGBF r g b) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + +instance ColorPlane PixelRGBF PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGBF PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGBF PlaneBlue where + toComponentIndex _ _ = 2 + +-------------------------------------------------- +---- PixelRGB16 instances +-------------------------------------------------- +instance Pixel PixelRGB16 where + type PixelBaseComponent PixelRGB16 = Pixel16 + + {-# INLINE mixWith #-} + mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) = + PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) + + {-# INLINE colorMap #-} + colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) + + componentCount _ = 3 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + return $ PixelRGB16 rv gv bv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + + unsafePixelAt v idx = + PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) + unsafeReadPixel vec idx = + PixelRGB16 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + unsafeWritePixel v idx (PixelRGB16 r g b) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + +instance ColorPlane PixelRGB16 PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGB16 PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGB16 PlaneBlue where + toComponentIndex _ _ = 2 + +instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where + {-# INLINE convertPixel #-} + convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b) + +instance ColorConvertible PixelRGB16 PixelRGBA16 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound + +instance LumaPlaneExtractable PixelRGB16 where + {-# INLINE computeLuma #-} + computeLuma (PixelRGB16 r g b) = floor $ 0.3 * toRational r + + 0.59 * toRational g + + 0.11 * toRational b +-------------------------------------------------- +---- PixelRGB8 instances +-------------------------------------------------- +instance Pixel PixelRGB8 where + type PixelBaseComponent PixelRGB8 = Word8 + + {-# INLINE mixWith #-} + mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = + PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) + + {-# INLINE colorMap #-} + colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b) + + componentCount _ = 3 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + return $ PixelRGB8 rv gv bv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + + unsafePixelAt v idx = + PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) + unsafeReadPixel vec idx = + PixelRGB8 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + unsafeWritePixel v idx (PixelRGB8 r g b) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + +instance ColorConvertible PixelRGB8 PixelRGBA8 where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound + +instance ColorConvertible PixelRGB8 PixelRGBF where + {-# INLINE promotePixel #-} + promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) + where toF v = fromIntegral v / 255.0 + +instance ColorPlane PixelRGB8 PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGB8 PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGB8 PlaneBlue where + toComponentIndex _ _ = 2 + +instance LumaPlaneExtractable PixelRGB8 where + {-# INLINE computeLuma #-} + computeLuma (PixelRGB8 r g b) = floor $ 0.3 * toRational r + + 0.59 * toRational g + + 0.11 * toRational b + +-------------------------------------------------- +---- PixelRGBA8 instances +-------------------------------------------------- +instance Pixel PixelRGBA8 where + type PixelBaseComponent PixelRGBA8 = Word8 + + {-# INLINE mixWith #-} + mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = + PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) + + {-# INLINE colorMap #-} + colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) + + componentCount _ = 4 + + pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + av <- arr .!!!. (baseIdx + 3) + return $ PixelRGBA8 rv gv bv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + (arr .<-. (baseIdx + 3)) av + + unsafePixelAt v idx = + PixelRGBA8 (V.unsafeIndex v idx) + (V.unsafeIndex v $ idx + 1) + (V.unsafeIndex v $ idx + 2) + (V.unsafeIndex v $ idx + 3) + unsafeReadPixel vec idx = + PixelRGBA8 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + `ap` M.unsafeRead vec (idx + 3) + unsafeWritePixel v idx (PixelRGBA8 r g b a) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + >> M.unsafeWrite v (idx + 3) a + +instance ColorPlane PixelRGBA8 PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGBA8 PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGBA8 PlaneBlue where + toComponentIndex _ _ = 2 + +instance ColorPlane PixelRGBA8 PlaneAlpha where + toComponentIndex _ _ = 3 + +-------------------------------------------------- +---- PixelRGBA16 instances +-------------------------------------------------- +instance Pixel PixelRGBA16 where + type PixelBaseComponent PixelRGBA16 = Pixel16 + + {-# INLINE mixWith #-} + mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = + PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) + + {-# INLINE colorMap #-} + colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a) + + componentCount _ = 4 + + pixelAt image@(Image { imageData = arr }) x y = + PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + av <- arr .!!!. (baseIdx + 3) + return $ PixelRGBA16 rv gv bv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + (arr .<-. (baseIdx + 3)) av + + unsafePixelAt v idx = + PixelRGBA16 (V.unsafeIndex v idx) + (V.unsafeIndex v $ idx + 1) + (V.unsafeIndex v $ idx + 2) + (V.unsafeIndex v $ idx + 3) + unsafeReadPixel vec idx = + PixelRGBA16 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + `ap` M.unsafeRead vec (idx + 3) + unsafeWritePixel v idx (PixelRGBA16 r g b a) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + >> M.unsafeWrite v (idx + 3) a + + +instance TransparentPixel PixelRGBA16 PixelRGB16 where + {-# INLINE dropTransparency #-} + dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b + {-# INLINE getTransparency #-} + getTransparency (PixelRGBA16 _ _ _ a) = a + +instance ColorPlane PixelRGBA16 PlaneRed where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelRGBA16 PlaneGreen where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelRGBA16 PlaneBlue where + toComponentIndex _ _ = 2 + +instance ColorPlane PixelRGBA16 PlaneAlpha where + toComponentIndex _ _ = 3 + +-------------------------------------------------- +---- PixelYCbCr8 instances +-------------------------------------------------- +instance Pixel PixelYCbCr8 where + type PixelBaseComponent PixelYCbCr8 = Word8 + + {-# INLINE mixWith #-} + mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) = + PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) + + {-# INLINE colorMap #-} + colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr) + componentCount _ = 3 + pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + yv <- arr .!!!. baseIdx + cbv <- arr .!!!. (baseIdx + 1) + crv <- arr .!!!. (baseIdx + 2) + return $ PixelYCbCr8 yv cbv crv + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) yv + (arr .<-. (baseIdx + 1)) cbv + (arr .<-. (baseIdx + 2)) crv + + unsafePixelAt v idx = + PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) + unsafeReadPixel vec idx = + PixelYCbCr8 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + unsafeWritePixel v idx (PixelYCbCr8 y cb cr) = + M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb + >> M.unsafeWrite v (idx + 2) cr + +instance (Pixel a) => ColorSpaceConvertible a a where + convertPixel = id + convertImage = id + +scaleBits, oneHalf :: Int +scaleBits = 16 +oneHalf = 1 `unsafeShiftL` (scaleBits - 1) + +fix :: Float -> Int +fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5 + + +rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int +rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ] +gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ] +bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ] +rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ] +gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ] +bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ] +gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ] +bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ] + + +instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where + {-# INLINE convertPixel #-} + convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr) + where ri = fromIntegral r + gi = fromIntegral g + bi = fromIntegral b + + y = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits + cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits + cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits + + convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData + where maxi = w * h + + rY = fix 0.29900 + gY = fix 0.58700 + bY = fix 0.11400 + rCb = (- fix 0.16874) + gCb = (- fix 0.33126) + bCb = fix 0.5 + gCr = (- fix 0.41869) + bCr = (- fix 0.08131) + + newData = runST $ do + block <- M.new $ maxi * 3 + let traductor _ idx | idx >= maxi = return block + traductor readIdx idx = do + let ri = fromIntegral $ d `V.unsafeIndex` readIdx + gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) + bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) + + y = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits + cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits + cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits + + (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y + (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb + (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr + traductor (readIdx + 3) (idx + 1) + + traductor 0 0 >>= V.freeze + +crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int +crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] +cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] +crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]] +cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]] + +instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where + {-# INLINE convertPixel #-} + convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) + where clampWord8 = fromIntegral . max 0 . min 255 + yi = fromIntegral y + cbi = fromIntegral cb + cri = fromIntegral cr + + r = yi + crRTab `V.unsafeIndex` cri + g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits + b = yi + cbBTab `V.unsafeIndex` cbi + + convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData + where maxi = w * h + clampWord8 v | v < 0 = 0 + | v > 255 = 255 + | otherwise = fromIntegral v + + newData = runST $ do + block <- M.new $ maxi * 3 + let traductor _ idx | idx >= maxi = return block + traductor readIdx idx = do + let yi = fromIntegral $ d `V.unsafeIndex` readIdx + cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) + cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) + + r = yi + crRTab `V.unsafeIndex` cri + g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits + b = yi + cbBTab `V.unsafeIndex` cbi + + (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r + (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g + (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b + traductor (readIdx + 3) (idx + 1) + + traductor 0 0 >>= V.freeze + +instance ColorPlane PixelYCbCr8 PlaneLuma where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelYCbCr8 PlaneCb where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelYCbCr8 PlaneCr where + toComponentIndex _ _ = 2 + +-------------------------------------------------- +---- PixelCMYK8 instances +-------------------------------------------------- +instance Pixel PixelCMYK8 where + type PixelBaseComponent PixelCMYK8 = Word8 + + {-# INLINE mixWith #-} + mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) = + PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) + + {-# INLINE colorMap #-} + colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k) + + componentCount _ = 4 + + pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + av <- arr .!!!. (baseIdx + 3) + return $ PixelCMYK8 rv gv bv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + (arr .<-. (baseIdx + 3)) av + + unsafePixelAt v idx = + PixelCMYK8 (V.unsafeIndex v idx) + (V.unsafeIndex v $ idx + 1) + (V.unsafeIndex v $ idx + 2) + (V.unsafeIndex v $ idx + 3) + unsafeReadPixel vec idx = + PixelCMYK8 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + `ap` M.unsafeRead vec (idx + 3) + unsafeWritePixel v idx (PixelCMYK8 r g b a) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + >> M.unsafeWrite v (idx + 3) a + +instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where + convertPixel (PixelCMYK8 c m y k) = + PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) + where + clampWord8 = fromIntegral . (`unsafeShiftR` 8) + ik :: Int + ik = 255 - fromIntegral k + + r = (255 - fromIntegral c) * ik + g = (255 - fromIntegral m) * ik + b = (255 - fromIntegral y) * ik + + +{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b) + -> (Word8, Word8, Word8) -> b #-} +{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b) + -> (Word16, Word16, Word16) -> b #-} +integralRGBToCMYK :: (Bounded a, Integral a) + => (a -> a -> a -> a -> b) -- ^ Pixel building function + -> (a, a, a) -- ^ RGB sample + -> b -- ^ Resulting sample +integralRGBToCMYK build (r, g, b) = + build (clamp c) (clamp m) (clamp y) (fromIntegral kInt) + where maxi = maxBound + + ir = fromIntegral $ maxi - r :: Int + ig = fromIntegral $ maxi - g + ib = fromIntegral $ maxi - b + + kInt = minimum [ir, ig, ib] + ik = fromIntegral maxi - kInt + + c = (ir - kInt) `div` ik + m = (ig - kInt) `div` ik + y = (ib - kInt) `div` ik + + clamp = fromIntegral . (max 0) + +instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where + convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) + +instance ColorPlane PixelCMYK8 PlaneCyan where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelCMYK8 PlaneMagenta where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelCMYK8 PlaneYellow where + toComponentIndex _ _ = 2 + +instance ColorPlane PixelCMYK8 PlaneBlack where + toComponentIndex _ _ = 3 + +-------------------------------------------------- +---- PixelCMYK16 instances +-------------------------------------------------- +instance Pixel PixelCMYK16 where + type PixelBaseComponent PixelCMYK16 = Word16 + + {-# INLINE mixWith #-} + mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) = + PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) + + {-# INLINE colorMap #-} + colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k) + + componentCount _ = 4 + + pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0)) + (arr ! (baseIdx + 1)) + (arr ! (baseIdx + 2)) + (arr ! (baseIdx + 3)) + where baseIdx = pixelBaseIndex image x y + + readPixel image@(MutableImage { mutableImageData = arr }) x y = do + rv <- arr .!!!. baseIdx + gv <- arr .!!!. (baseIdx + 1) + bv <- arr .!!!. (baseIdx + 2) + av <- arr .!!!. (baseIdx + 3) + return $ PixelCMYK16 rv gv bv av + where baseIdx = mutablePixelBaseIndex image x y + + writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do + let baseIdx = mutablePixelBaseIndex image x y + (arr .<-. (baseIdx + 0)) rv + (arr .<-. (baseIdx + 1)) gv + (arr .<-. (baseIdx + 2)) bv + (arr .<-. (baseIdx + 3)) av + + unsafePixelAt v idx = + PixelCMYK16 (V.unsafeIndex v idx) + (V.unsafeIndex v $ idx + 1) + (V.unsafeIndex v $ idx + 2) + (V.unsafeIndex v $ idx + 3) + unsafeReadPixel vec idx = + PixelCMYK16 `liftM` M.unsafeRead vec idx + `ap` M.unsafeRead vec (idx + 1) + `ap` M.unsafeRead vec (idx + 2) + `ap` M.unsafeRead vec (idx + 3) + unsafeWritePixel v idx (PixelCMYK16 r g b a) = + M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g + >> M.unsafeWrite v (idx + 2) b + >> M.unsafeWrite v (idx + 3) a + +instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where + convertPixel (PixelCMYK16 c m y k) = + PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b) + where + clampWord16 = fromIntegral . (`unsafeShiftR` 16) + ik :: Int + ik = 65535 - fromIntegral k + + r = (65535 - fromIntegral c) * ik + g = (65535 - fromIntegral m) * ik + b = (65535 - fromIntegral y) * ik + +instance ColorPlane PixelCMYK16 PlaneCyan where + toComponentIndex _ _ = 0 + +instance ColorPlane PixelCMYK16 PlaneMagenta where + toComponentIndex _ _ = 1 + +instance ColorPlane PixelCMYK16 PlaneYellow where + toComponentIndex _ _ = 2 + +instance ColorPlane PixelCMYK16 PlaneBlack where + toComponentIndex _ _ = 3 + +-- | Perform a gamma correction for an image with HDR pixels. +gammaCorrection :: PixelF -- ^ Gamma value, should be between 0.5 and 3.0 + -> Image PixelRGBF -- ^ Image to treat. + -> Image PixelRGBF +gammaCorrection gammaVal = pixelMap gammaCorrector + where gammaExponent = 1.0 / gammaVal + fixVal v = v ** gammaExponent + gammaCorrector (PixelRGBF r g b) = + PixelRGBF (fixVal r) (fixVal g) (fixVal b) + +-- | Perform a tone mapping operation on an High dynamic range image. +toneMapping :: PixelF -- ^ Exposure parameter + -> Image PixelRGBF -- ^ Image to treat. + -> Image PixelRGBF +toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData + where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0); + maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img + scaledData = V.map (* coeff) $ imageData img + diff --git a/src/Codec/Picture/VectorByteConversion.hs b/src/Codec/Picture/VectorByteConversion.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/VectorByteConversion.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +module Codec.Picture.VectorByteConversion( blitVector + , toByteString + , imageFromUnsafePtr ) where + +import Data.Word( Word8 ) +import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) +import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) +import Foreign.Storable( Storable, sizeOf ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as S + +import Codec.Picture.Types + +blitVector :: Vector Word8 -> Int -> Int -> B.ByteString +blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize + where (ptr, offset, _length) = unsafeToForeignPtr vec + +toByteString :: forall a. (Storable a) => Vector a -> B.ByteString +toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) + where (ptr, offset, len) = unsafeToForeignPtr vec + size = sizeOf (undefined :: a) + +imageFromUnsafePtr :: forall px + . (Pixel px, (PixelBaseComponent px) ~ Word8) + => Int -> Int -> ForeignPtr Word8 -> Image px +imageFromUnsafePtr width height ptr = + Image width height $ unsafeFromForeignPtr0 ptr size + where compCount = componentCount (undefined :: px) + size = width * height * compCount +