diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.4 +Version: 3.2.5 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -18,7 +18,7 @@ -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.10 -extra-source-files: changelog, docimages/*.png, docimages/*.svg +extra-source-files: changelog, docimages/*.png, docimages/*.svg, README.md extra-doc-files: docimages/*.png, docimages/*.svg Source-Repository head @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.4 + Tag: v3.2.5 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -45,13 +45,15 @@ Codec.Picture.HDR, Codec.Picture.Tga, Codec.Picture.Tiff, + Codec.Picture.Metadata, + Codec.Picture.Metadata.Exif, Codec.Picture.Saving, Codec.Picture.Types, Codec.Picture.ColorQuant Ghc-options: -O3 -Wall Ghc-prof-options: -rtsopts -Wall -prof -auto-all - Build-depends: base >= 4 && < 5, + Build-depends: base >= 4.5 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.3, binary >= 0.5 && < 0.8, @@ -68,6 +70,7 @@ -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable, + Codec.Picture.Jpg.Metadata, Codec.Picture.Jpg.FastIdct, Codec.Picture.Jpg.FastDct, Codec.Picture.Jpg.Types, @@ -77,6 +80,9 @@ Codec.Picture.Gif.LZWEncoding, Codec.Picture.Png.Export, Codec.Picture.Png.Type, + Codec.Picture.Png.Metadata, + Codec.Picture.Tiff.Metadata, + Codec.Picture.Tiff.Types, Codec.Picture.BitWriter, Codec.Picture.InternalHelper, Codec.Picture.VectorByteConversion diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,114 @@ +![Juicy logo](https://raw.github.com/Twinside/Juicy.Pixels/master/docimages/juicy.png) + + +[![Build Status](https://travis-ci.org/Twinside/Juicy.Pixels.png?branch=master)](https://travis-ci.org/Twinside/Juicy.Pixels) +[![Hackage](https://img.shields.io/hackage/v/JuicyPixels.svg)](http://hackage.haskell.org/package/JuicyPixels) + +Juicy.Pixels +============ + +This library provides saving & loading of different picture formats for the +Haskell language. The aim of the library is to be as lightweight as possible, +you ask it to load an image, and it'll dump you a big Vector full of juicy +pixels. Or squared pixels, or whatever, as long as they're unboxed. + +Documentation +------------- +The library documentation can be accessed on [Hackage](http://hackage.haskell.org/package/JuicyPixels) + +Wrappers +-------- +For the user of +[REPA](http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial), +check-out JuicyPixels-repa on +[GitHub](https://github.com/TomMD/JuicyPixels-repa) or +[Hackage](http://hackage.haskell.org/package/JuicyPixels-repa) + +For the user of +[Gloss](http://hackage.haskell.org/package/gloss), +check-out gloss-juicy on +[GitHub](https://github.com/alpmestan/gloss-juicy) or +[Hackage](http://hackage.haskell.org/package/gloss-juicy) + +Status +------ + + - PNG (.png) + * Reading + - 1,2,4,8 bits loading, Grayscale, 24bits, 24 bits with alpha, + interleaved & filtered (fully compliant with the standard, + tested against png suite). + + * Writing + - 8bits RGB (non interleaved) + - 8bits RGBA (non interleaved) + - 8bits greyscale (non interleaved) + - 16bits greyscale (non interleaved) + - 16bits RGB (non interleaved) + - 16bits RGBA (non interleaved) + + * Metadata (reading/writing) + * in a tEXT chunk: 'Title', 'Description', 'Author', 'Copyright', + 'Software', 'Comment', 'Disclaimer', 'Source', 'Warning' + * any other tEXT chunk. + * in a gAMA field : 'Gamma' + * DPI information in a pHYs chunk. + + - Bitmap (.bmp) (mainly used as a debug output format) + * Reading + - 24bits (RGB) images + - 8bits (greyscale & paletted) images + + * Writing + - 32bits (RGBA) per pixel images + - 24bits (RGB) per pixel images + - 8 bits greyscale (with palette) + + * Metadata (reading/writing): DPI information + + - Jpeg (.jpg, .jpeg) + * Reading normal and interlaced baseline DCT image + - YCbCr (default) CMYK/YCbCrK/RGB colorspaces + * Writing non-interlaced JPG + + * Metadata: + - Reading and writing DpiX & DpiY from JFIF header. + - Reading EXIF metadata. + + - Gif (.gif) + * Reading single image & animated Gif image, handles interlaced images. + * Writing single & animated Gif images. + * No metadata. + + - Radiance (.pic, .hdr) + * Reading + * Writing + * No metadata. + + - Tga + * Reading + - 8, 16, 24 & 32 bits + - paletted and unpaletted + - RLE encoded or uncompressed + * Writing + - uncompressed 8bits (Pixel8) + - uncompressed 24bits (PixelRGB8) + - uncompressed 32bits (PixelRGBA8) + * No metadata + + - Tiff + * Reading + - 2, 4, 8, 16 bit depth reading (planar and contiguous for each) + - CMYK, YCbCr, RGB, RGBA, Paletted, Greyscale + - Uncompressed, PackBits, LZW + + * Writing + - 8 and 16 bits + - CMYK, YCbCr, RGB, RGBA, Greyscale + - Uncompressed + * Metadata: reading DpiX, DpiY and EXIF informations. + +_I love juicy pixels_ + +You can make [donations on this page](http://twinside.github.com/Juicy.Pixels/). + diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,12 @@ --*-change-log-*- +Change log +========== +v3.2.5 May 2015 + * Adding: Metadata extraction for various file format. + * Adding: Metadata writing for various file format. + * Adding: light EXIF mapping. + * Fix: handling of Tiff with predictors (thanks to Patrick Pelletier) + v3.2.4 April 2015 * Adding: Traversals compatible with the lens library. diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs --- a/src/Codec/Picture.hs +++ b/src/Codec/Picture.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} -- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and @@ -14,7 +15,9 @@ module Codec.Picture ( -- * Generic functions readImage + , readImageWithMetadata , decodeImage + , decodeImageWithMetadata , pixelMap , generateImage , generateFoldImage @@ -133,15 +136,25 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) +import Data.Monoid( mempty ) #endif import Control.DeepSeq( NFData, deepseq ) import qualified Control.Exception as Exc ( catch, IOException ) -import Codec.Picture.Bitmap( BmpEncodable, decodeBitmap +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Bitmap( BmpEncodable + , decodeBitmap + , decodeBitmapWithMetadata , writeBitmap, encodeBitmap , encodeDynamicBitmap, writeDynamicBitmap ) -import Codec.Picture.Jpg( decodeJpeg, encodeJpeg, encodeJpegAtQuality ) -import Codec.Picture.Png( PngSavable( .. ), decodePng, writePng +import Codec.Picture.Jpg( decodeJpeg + , decodeJpegWithMetadata + , encodeJpeg + , encodeJpegAtQuality ) +import Codec.Picture.Png( PngSavable( .. ) + , decodePng + , decodePngWithMetadata + , writePng , encodeDynamicPng , encodePalettedPng , writeDynamicPng @@ -165,6 +178,7 @@ , writeHDR ) import Codec.Picture.Tiff( decodeTiff + , decodeTiffWithMetadata , TiffSaveable , encodeTiff , writeTiff ) @@ -185,8 +199,6 @@ 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 "" @@ -245,19 +257,32 @@ readImage :: FilePath -> IO (Either String DynamicImage) readImage = withImageDecoder decodeImage +-- | Equivalent to 'readImage' but also providing metadatas. +readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas)) +readImageWithMetadata = withImageDecoder decodeImageWithMetadata + -- | 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 succeeds, it 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) - ,("TGA", decodeTga) - ] +decodeImage = fmap fst . decodeImageWithMetadata + +-- | Equivalent to 'decodeImage', but also provide potential metadatas +-- present in the given file. +decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeImageWithMetadata str = eitherLoad str + [ ("Jpeg", decodeJpegWithMetadata) + , ("PNG", decodePngWithMetadata) + , ("Bitmap", decodeBitmapWithMetadata) + , ("GIF", noMeta decodeGif) + , ("HDR", noMeta decodeHDR) + , ("Tiff", decodeTiffWithMetadata) + , ("TGA", noMeta decodeTga) + ] + where + noMeta f = fmap (, mempty) . f + -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage) diff --git a/src/Codec/Picture/BitWriter.hs b/src/Codec/Picture/BitWriter.hs --- a/src/Codec/Picture/BitWriter.hs +++ b/src/Codec/Picture/BitWriter.hs @@ -1,303 +1,305 @@ -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE CPP #-} --- | 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 - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>), (<$>) ) -#endif - -import Data.STRef -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( (.&.), (.|.), 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 = aux 0 - 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 = pushByte' st - - 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 - +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE CPP #-} +-- | 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 + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<*>), (<$>) ) +#endif + +import Data.STRef +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( (.&.), (.|.), 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 = aux 0 + 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 = pushByte' st + + 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 + +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Bitmap.hs b/src/Codec/Picture/Bitmap.hs --- a/src/Codec/Picture/Bitmap.hs +++ b/src/Codec/Picture/Bitmap.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -7,14 +8,24 @@ module Codec.Picture.Bitmap( -- * Functions writeBitmap , encodeBitmap + , encodeBitmapWithMetadata , decodeBitmap + , decodeBitmapWithMetadata , encodeDynamicBitmap + , encodeBitmapWithPaletteAndMetadata , writeDynamicBitmap -- * Accepted format in output , BmpEncodable( ) ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<$>) ) +#endif + import Control.Monad( when, forM_ ) import Control.Monad.ST ( ST, runST ) +import Data.Maybe( fromMaybe ) import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M @@ -41,6 +52,8 @@ import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.VectorByteConversion +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata ( Metadatas ) data BmpHeader = BmpHeader { magicIdentifier :: !Word16 @@ -298,6 +311,12 @@ _ <- getWord8 return $ PixelRGB8 r g b +metadataOfHeader :: BmpInfoHeader -> Metadatas +metadataOfHeader hdr = Met.insert Met.DpiY dpiY $ Met.singleton Met.DpiX dpiX + where + dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr + dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr + -- | Try to decode a bitmap image. -- Right now this function can output the following pixel types : -- @@ -306,7 +325,11 @@ -- * Pixel8 -- decodeBitmap :: B.ByteString -> Either String DynamicImage -decodeBitmap str = flip runGetStrict str $ do +decodeBitmap = fmap fst . decodeBitmapWithMetadata + +-- | Same as 'decodeBitmap' but also extracts metadata. +decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeBitmapWithMetadata str = flip runGetStrict str $ do hdr <- get :: Get BmpHeader bmpHeader <- get :: Get BmpInfoHeader @@ -327,13 +350,14 @@ skip . fromIntegral $ dataOffset hdr - fromIntegral readed' rest <- getRemainingBytes + let addMetadata i = (i, metadataOfHeader bmpHeader) case (bitPerPixel bmpHeader, planes bmpHeader, bitmapCompression bmpHeader) of -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" - (24, 1, 0) -> return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest + (24, 1, 0) -> return . addMetadata . ImageRGB8 $ decodeImageRGB8 bmpHeader rest ( 8, 1, 0) -> let indexer v = table V.! fromIntegral v in - return . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest + return . addMetadata . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest a -> fail $ "Can't handle BMP file " ++ show a @@ -352,6 +376,16 @@ encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) +-- | Equivalent to 'encodeBitmap' but also store +-- the following metadatas: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel + => Metadatas -> Image pixel -> L.ByteString +encodeBitmapWithMetadata metas = + encodeBitmapWithPaletteAndMetadata metas (defaultPalette (undefined :: pixel)) -- | Write a dynamic image in a .bmp image file if possible. -- The same restriction as encodeDynamicBitmap apply. @@ -374,13 +408,30 @@ encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" +extractDpiOfMetadata :: Metadatas -> (Word32, Word32) +extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where + fetch k = fromMaybe 0 + $ fromIntegral . Met.dotPerInchToDotsPerMeter <$> Met.lookup k metas + -- | 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 = +encodeBitmapWithPalette = encodeBitmapWithPaletteAndMetadata mempty + +-- | Equivalent to 'encodeBitmapWithPalette' but also store +-- the following metadatas: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel) + => Metadatas -> BmpPalette -> Image pixel + -> L.ByteString +encodeBitmapWithPaletteAndMetadata metas pal@(BmpPalette palette) img = runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img where imgWidth = fromIntegral $ imageWidth img imgHeight = fromIntegral $ imageHeight img + (dpiX, dpiY) = extractDpiOfMetadata metas paletteSize = fromIntegral $ length palette bpp = bitsPerPixel (undefined :: pixel) @@ -402,10 +453,12 @@ bitPerPixel = fromIntegral bpp, bitmapCompression = 0, -- no compression byteImageSize = imagePixelSize, - xResolution = 0, - yResolution = 0, + xResolution = dpiX, + yResolution = dpiY, colorCount = 0, importantColours = paletteSize } + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -8,11 +8,15 @@ {-# OPTIONS_GHC -fspec-constr-count=5 #-} -- | Module used for JPEG file loading and writing. module Codec.Picture.Jpg( decodeJpeg + , decodeJpegWithMetadata , encodeJpegAtQuality + , encodeJpegAtQualityWithMetadata , encodeJpeg ) where #if !MIN_VERSION_base(4,8,0) +import Data.Foldable( foldMap ) +import Data.Monoid( mempty ) import Control.Applicative( pure, (<$>) ) #endif @@ -25,6 +29,7 @@ import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS ) import Data.Bits( (.|.), unsafeShiftL ) +import Data.Monoid( (<>) ) import Data.Int( Int16, Int32 ) import Data.Word(Word8, Word32) import Data.Binary( Binary(..), encode ) @@ -42,11 +47,15 @@ import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Tiff.Types +import Codec.Picture.Tiff.Metadata 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 +import Codec.Picture.Jpg.Metadata quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32) @@ -150,7 +159,7 @@ val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) (img `M.unsafeWrite` idx) val0 - (img `M.unsafeWrite` (idx + (3 ))) val1 + (img `M.unsafeWrite` (idx + 3 )) val1 (img `M.unsafeWrite` (idx + (3 * 2))) val2 (img `M.unsafeWrite` (idx + (3 * 3))) val3 (img `M.unsafeWrite` (idx + (3 * 4))) val4 @@ -235,6 +244,8 @@ , currentRestartInterv :: !Int , currentFrame :: Maybe JpgFrameHeader , app14Marker :: !(Maybe JpgAdobeApp14) + , app0JFifMarker :: !(Maybe JpgJFIFApp0) + , app1ExifMarker :: !(Maybe [ImageFileDirectory]) , componentIndexMapping :: ![(Word8, Int)] , isProgressive :: !Bool , maximumHorizontalResolution :: !Int @@ -261,6 +272,8 @@ , currentFrame = Nothing , componentIndexMapping = [] , app14Marker = Nothing + , app0JFifMarker = Nothing + , app1ExifMarker = Nothing , isProgressive = False , maximumHorizontalResolution = 0 , maximumVerticalResolution = 0 @@ -272,6 +285,10 @@ jpgMachineStep :: JpgFrame -> JpgScripter s () jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s -> s { app14Marker = Just app14 } +jpgMachineStep (JpgExif exif) = modify $ \s -> + s { app1ExifMarker = Just exif } +jpgMachineStep (JpgJFIF app0) = modify $ \s -> + s { app0JFifMarker = Just app0 } jpgMachineStep (JpgAppFrame _ _) = pure () jpgMachineStep (JpgExtension _ _) = pure () jpgMachineStep (JpgScanBlob hdr raw_data) = do @@ -530,15 +547,36 @@ -- * PixelYCbCr8 -- decodeJpeg :: B.ByteString -> Either String DynamicImage -decodeJpeg file = case runGetStrict get file of +decodeJpeg = fmap fst . decodeJpegWithMetadata + +-- | Equivalent to 'decodeJpeg' but also extracts metadatas. +-- +-- Extract the following metadatas from the JFIF bloc: +-- +-- * DpiX +-- +-- * DpiY +-- +-- Exif metadata are also extracted if present. +-- +decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeJpegWithMetadata file = case runGetStrict get file of Left err -> Left err Right img -> case imgKind of Just BaseLineDCT -> - let (st, arr) = decodeBaseline in - dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + let (st, arr) = decodeBaseline + jfifMeta = foldMap extractMetadatas $ app0JFifMarker st + exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st + meta = jfifMeta <> exifMeta + in + (, meta) <$> + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr Just ProgressiveDCT -> - let (st, arr) = decodeProgressive in - dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + let (st, arr) = decodeProgressive + meta = foldMap extractMetadatas $ app0JFifMarker st + in + (, meta) <$> + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr _ -> Left "Unkown JPG kind" where compCount = length $ jpgComponents scanInfo @@ -703,12 +741,26 @@ 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 - ] +encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty + +-- | Equivalent to 'encodeJpegAtQuality', but will store the following +-- metadatas in the file using a JFIF block: +-- +-- * 'Codec.Picture.Metadata.DpiX' +-- * 'Codec.Picture.Metadata.DpiY' +-- +encodeJpegAtQualityWithMetadata :: Word8 -- ^ Quality factor + -> Metadatas + -> Image PixelYCbCr8 -- ^ Image to encode + -> L.ByteString -- ^ Encoded JPEG +encodeJpegAtQualityWithMetadata quality metas img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage + where finalImage = JpgImage $ + encodeMetadatas metas ++ + [ JpgQuantTable quantTables + , JpgScans JpgBaselineDCTHuffman hdr + , JpgHuffmanTable defaultHuffmanTables + , JpgScanBlob scanHeader encodedImage + ] outputComponentCount = 3 diff --git a/src/Codec/Picture/Jpg/DefaultTable.hs b/src/Codec/Picture/Jpg/DefaultTable.hs --- a/src/Codec/Picture/Jpg/DefaultTable.hs +++ b/src/Codec/Picture/Jpg/DefaultTable.hs @@ -60,7 +60,7 @@ table <- M.replicate 512 0x8000 let aux (Empty) idx = return $ idx + 1 aux (Leaf v) idx = do - (table `M.unsafeWrite` idx) $ (fromIntegral v .|. 0x4000) + (table `M.unsafeWrite` idx) $ fromIntegral v .|. 0x4000 return $ idx + 1 aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = diff --git a/src/Codec/Picture/Jpg/FastDct.hs b/src/Codec/Picture/Jpg/FastDct.hs --- a/src/Codec/Picture/Jpg/FastDct.hs +++ b/src/Codec/Picture/Jpg/FastDct.hs @@ -1,208 +1,218 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -#endif - -import Data.Int( Int16, Int32 ) -import Data.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) +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Int( Int16, Int32 ) +import Data.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 = do + 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) = do + toSum <- + 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) + return $ sum toSum + + 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 = dataBlock `M.unsafeWrite` (baseIdx + idx) + 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 = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i)) + 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) + +{-# ANN module "HLint: ignore Use camelCase" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Jpg/Metadata.hs b/src/Codec/Picture/Jpg/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Jpg/Metadata.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Metadata ( extractMetadatas, encodeMetadatas ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Monoid( mempty ) +import Data.Word( Word ) +#endif + +import Data.Word( Word16 ) +import Data.Maybe( fromMaybe ) +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Jpg.Types + +scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas +scalerOfUnit unit k v = case unit of + JFifUnitUnknown -> id + JFifPixelsPerInch -> Met.insert k (fromIntegral v) + JFifPixelsPerCentimeter -> + Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v) + +extractMetadatas :: JpgJFIFApp0 -> Metadatas +extractMetadatas jfif = + inserter Met.DpiX (_jfifDpiX jfif) + $ inserter Met.DpiY (_jfifDpiY jfif) mempty + where + inserter = scalerOfUnit $ _jfifUnit jfif + + +encodeMetadatas :: Metadatas -> [JpgFrame] +encodeMetadatas metas = fromMaybe [] $ do + dpiX <- Met.lookup Met.DpiX metas + dpiY <- Met.lookup Met.DpiY metas + pure . pure . JpgJFIF $ JpgJFIFApp0 + { _jfifUnit = JFifPixelsPerInch + , _jfifDpiX = fromIntegral dpiX + , _jfifDpiY = fromIntegral dpiY + , _jfifThumbnail = Nothing + } + diff --git a/src/Codec/Picture/Jpg/Progressive.hs b/src/Codec/Picture/Jpg/Progressive.hs --- a/src/Codec/Picture/Jpg/Progressive.hs +++ b/src/Codec/Picture/Jpg/Progressive.hs @@ -1,327 +1,325 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Progressive - ( JpgUnpackerParameter( .. ) - , progressiveUnpack - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<$>) ) -#endif - -import Control.Monad( when, 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 idx | idx > maxIndex = pure () - performEobRun idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if (coeff /= 0) then do - bit <- getNextBitJpg - case (bit, (coeff .&. plusOne) == 0) of - (False, _) -> performEobRun $ idx + 1 - (True, False) -> performEobRun $ idx + 1 - (True, True) -> do - let newVal | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) newVal - performEobRun $ idx + 1 - else - performEobRun $ idx + 1 - - unpack idx | idx > maxIndex = pure 0 - unpack idx = do - rrrrssss <- decodeRrrrSsss $ acHuffmanTree params - case rrrrssss of - (0xF, 0) -> do - idx' <- updateCoeffs 0xF idx - unpack $ idx' + 1 - - ( r, 0) -> do - lowBits <- unpackInt r - let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 - performEobRun idx - pure newEobRun - - ( r, _) -> do - val <- getBitVal - idx' <- updateCoeffs (fromIntegral r) idx - when (idx' <= maxIndex) $ - (lift $ (block `MS.unsafeWrite` idx') val) - unpack $ idx' + 1 - - updateCoeffs :: Int -> Int -> BoolReader s Int - updateCoeffs r idx - | r < 0 = pure $ idx - 1 - | idx > maxIndex = pure idx - updateCoeffs r idx = do - coeff <- lift $ block `MS.unsafeRead` idx - if coeff /= 0 then do - bit <- getNextBitJpg - when (bit && coeff .&. plusOne == 0) $ do - let writeCoeff | coeff >= 0 = coeff + plusOne - | otherwise = coeff + minusOne - lift $ (block `MS.unsafeWrite` idx) writeCoeff - updateCoeffs r $ idx + 1 - else - updateCoeffs (r - 1) $ idx + 1 - -type Unpacker s = - JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 - -> BoolReader s Int32 - - -prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] - -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) - , M.STVector s BoolState) -prepareUnpacker lst = do - let boolStates = V.fromList $ map snd infos - vec <- V.unsafeThaw boolStates - return (V.fromList $ map fst infos, vec) - where infos = map prepare lst - prepare ([], _) = error "progressiveUnpack, no component" - prepare (whole@((param, _) : _) , byteString) = - (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) - where unpacker = selection (successiveApprox param) (coefficientRange param) - boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString - - selection (_, 0) (0, _) = decodeFirstDC - selection (_, 0) _ = decodeFirstAc - selection _ (0, _) = decodeRefineDc - selection _ _ = decodeRefineAc - -data ComponentData s = ComponentData - { componentIndices :: V.Vector (VS.Vector Int) - , componentBlocks :: V.Vector (MutableMacroBlock s Int16) - , componentId :: !Int - , componentBlockCount :: !Int - } - --- | Iteration from 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 - comp = jpgComponents frame !! cId - quantId = - fromIntegral $ quantizationTableDest comp - table = quants ! min 3 quantId - compW = fromIntegral $ horizontalSamplingFactor comp - compH = fromIntegral $ verticalSamplingFactor comp - cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 - ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 - - rasterMap (imageMcuWidth * compW) compH $ \rx y -> do - let ry = mmY * maxiH + y - block = compBlocks ! (y * imageMcuWidth * compW + rx) - transformed <- decodeMacroBlock table workBlock block - unpackMacroBlock imgComponentCount - cw8 ch8 cId (rx * cw8) ry - img transformed - - return img - - where imgComponentCount = length $ jpgComponents frame - - imgWidth = fromIntegral $ jpgWidth frame - imgHeight = fromIntegral $ jpgHeight frame - - imageBlockWidth = (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 - +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Progressive + ( JpgUnpackerParameter( .. ) + , progressiveUnpack + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<$>) ) +#endif + +import Control.Monad( when, unless, forM_ ) +import Control.Monad.ST( ST ) +import Control.Monad.Trans( lift ) +import Data.Bits( (.&.), (.|.), unsafeShiftL ) +import Data.Int( Int16, Int32 ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS +import Data.Vector( (!) ) +import qualified Data.Vector.Mutable as M +import qualified Data.Vector.Storable.Mutable as MS + +import Codec.Picture.Types +import Codec.Picture.BitWriter +import Codec.Picture.Jpg.Common +import Codec.Picture.Jpg.Types +import Codec.Picture.Jpg.DefaultTable + +createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) +createMcuLineIndices param imgWidth mcuWidth = + V.fromList $ VS.fromList <$> [indexSolo, indexMulti] + where compW = fromIntegral $ horizontalSamplingFactor param + compH = fromIntegral $ verticalSamplingFactor param + imageBlockSize = (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 idx | idx > maxIndex = pure () + performEobRun idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + case (bit, (coeff .&. plusOne) == 0) of + (False, _) -> performEobRun $ idx + 1 + (True, False) -> performEobRun $ idx + 1 + (True, True) -> do + let newVal | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) newVal + performEobRun $ idx + 1 + else + performEobRun $ idx + 1 + + unpack idx | idx > maxIndex = pure 0 + unpack idx = do + rrrrssss <- decodeRrrrSsss $ acHuffmanTree params + case rrrrssss of + (0xF, 0) -> do + idx' <- updateCoeffs 0xF idx + unpack $ idx' + 1 + + ( r, 0) -> do + lowBits <- unpackInt r + let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 + performEobRun idx + pure newEobRun + + ( r, _) -> do + val <- getBitVal + idx' <- updateCoeffs (fromIntegral r) idx + when (idx' <= maxIndex) $ + lift $ (block `MS.unsafeWrite` idx') val + unpack $ idx' + 1 + + updateCoeffs :: Int -> Int -> BoolReader s Int + updateCoeffs r idx + | r < 0 = pure $ idx - 1 + | idx > maxIndex = pure idx + updateCoeffs r idx = do + coeff <- lift $ block `MS.unsafeRead` idx + if coeff /= 0 then do + bit <- getNextBitJpg + when (bit && coeff .&. plusOne == 0) $ do + let writeCoeff | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) writeCoeff + updateCoeffs r $ idx + 1 + else + updateCoeffs (r - 1) $ idx + 1 + +type Unpacker s = + JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 + -> BoolReader s Int32 + + +prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) + , M.STVector s BoolState) +prepareUnpacker lst = do + let boolStates = V.fromList $ map snd infos + vec <- V.unsafeThaw boolStates + return (V.fromList $ map fst infos, vec) + where infos = map prepare lst + prepare ([], _) = error "progressiveUnpack, no component" + prepare (whole@((param, _) : _) , byteString) = + (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) + where unpacker = selection (successiveApprox param) (coefficientRange param) + boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString + + selection (_, 0) (0, _) = decodeFirstDC + selection (_, 0) _ = decodeFirstAc + selection _ (0, _) = decodeRefineDc + selection _ _ = decodeRefineAc + +data ComponentData s = ComponentData + { componentIndices :: V.Vector (VS.Vector Int) + , componentBlocks :: V.Vector (MutableMacroBlock s Int16) + , componentId :: !Int + , componentBlockCount :: !Int + } + +-- | Iteration from to n in monadic context, without data +-- keeping. +lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () +{-# INLINE lineMap #-} +lineMap count f = go 0 + where go n | n >= count = return () + go n = f n >> go (n + 1) + +progressiveUnpack :: (Int, Int) + -> JpgFrameHeader + -> V.Vector (MacroBlock Int16) + -> [([(JpgUnpackerParameter, a)], L.ByteString)] + -> ST s (MutableImage s PixelYCbCr8) +progressiveUnpack (maxiW, maxiH) frame quants lst = do + (unpackers, readers) <- prepareUnpacker lst + allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame + :: ST s [ComponentData s] + let scanCount = length lst + restartIntervalValue = case lst of + ((p,_):_,_): _ -> restartInterval p + _ -> -1 + dcCoeffs <- MS.replicate imgComponentCount 0 + eobRuns <- MS.replicate (length lst) 0 + workBlock <- createEmptyMutableMacroBlock + writeIndices <- MS.replicate imgComponentCount (0 :: Int) + restartIntervals <- MS.replicate scanCount restartIntervalValue + let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount + img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 + + let processRestartInterval = + forM_ [0 .. scanCount - 1] $ \ix -> do + v <- restartIntervals `MS.read` ix + if v == 0 then do + -- reset DC prediction + when (ix == 0) (MS.set dcCoeffs 0) + reader <- readers `M.read` ix + (_, updated) <- runBoolReaderWith reader $ + byteAlignJpg >> decodeRestartInterval + (readers `M.write` ix) updated + (eobRuns `MS.unsafeWrite` ix) 0 + (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 + else + (restartIntervals `MS.unsafeWrite` ix) $ v - 1 + + + lineMap imageMcuHeight $ \mmY -> do + -- Reset all blocks to 0 + forM_ allBlocks $ V.mapM_ (`MS.set` 0) . componentBlocks + MS.set writeIndices 0 + + lineMap imageMcuWidth $ \_mmx -> do + processRestartInterval + V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do + boolState <- readers `M.read` readerIndex unpackParam + eobrun <- eobRuns `MS.read` readerIndex unpackParam + let componentNumber = componentIndex unpackParam + writeIndex <- writeIndices `MS.read` componentNumber + let componentData = allBlocks !! componentNumber + indexVector = + componentIndices componentData ! indiceVector unpackParam + maxIndexLength = VS.length indexVector + unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do + let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) + writeBlock = componentBlocks componentData ! realIndex + (eobrun', state) <- + runBoolReaderWith boolState $ + unpacker unpackParam dcCoeffs writeBlock eobrun + + (readers `M.write` readerIndex unpackParam) state + (eobRuns `MS.write` readerIndex unpackParam) eobrun' + + -- Update the write indices + forM_ allBlocks $ \comp -> do + writeIndex <- writeIndices `MS.read` componentId comp + let newIndex = writeIndex + componentBlockCount comp + (writeIndices `MS.write` componentId comp) newIndex + + forM_ allBlocks $ \compData -> do + let compBlocks = componentBlocks compData + cId = componentId compData + comp = jpgComponents frame !! cId + quantId = + fromIntegral $ quantizationTableDest comp + table = quants ! min 3 quantId + compW = fromIntegral $ horizontalSamplingFactor comp + compH = fromIntegral $ verticalSamplingFactor comp + cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1 + ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 + + rasterMap (imageMcuWidth * compW) compH $ \rx y -> do + let ry = mmY * maxiH + y + block = compBlocks ! (y * imageMcuWidth * compW + rx) + transformed <- decodeMacroBlock table workBlock block + unpackMacroBlock imgComponentCount + cw8 ch8 cId (rx * cw8) ry + img transformed + + return img + + where imgComponentCount = length $ jpgComponents frame + + imgWidth = fromIntegral $ jpgWidth frame + imgHeight = fromIntegral $ jpgHeight frame + + imageBlockWidth = (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 --- a/src/Codec/Picture/Jpg/Types.hs +++ b/src/Codec/Picture/Jpg/Types.hs @@ -1,628 +1,728 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Types( MutableMacroBlock - , createEmptyMutableMacroBlock - , printMacroBlock - , printPureMacroBlock - , DcCoefficient - , JpgImage( .. ) - , JpgComponent( .. ) - , JpgFrameHeader( .. ) - , JpgFrame( .. ) - , JpgFrameKind( .. ) - , JpgScanHeader( .. ) - , JpgQuantTableSpec( .. ) - , JpgHuffmanTableSpec( .. ) - , JpgImageKind( .. ) - , JpgScanSpecification( .. ) - , JpgColorSpace( .. ) - , AdobeTransform( .. ) - , JpgAdobeApp14( .. ) - , calculateSize - , dctBlockSize - ) where - - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<*>), (<$>) ) -#endif - -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.Char8 as BC -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 - , putByteString - ) - -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 - | JpgAdobeAPP14 !JpgAdobeApp14 - | JpgExtension !Word8 B.ByteString - | JpgQuantTable ![JpgQuantTableSpec] - | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] - | JpgScanBlob !JpgScanHeader !L.ByteString - | JpgScans !JpgFrameKind !JpgFrameHeader - | JpgIntervalRestart !Word16 - deriving Show - -data JpgColorSpace - = JpgColorSpaceYCbCr - | JpgColorSpaceYCC - | JpgColorSpaceY - | JpgColorSpaceYA - | JpgColorSpaceYCCA - | JpgColorSpaceYCCK - | JpgColorSpaceCMYK - | JpgColorSpaceRGB - | JpgColorSpaceRGBA - deriving Show - -data AdobeTransform - = AdobeUnknown -- ^ Value 0 - | AdobeYCbCr -- ^ value 1 - | AdobeYCck -- ^ value 2 - deriving Show - -data JpgAdobeApp14 = JpgAdobeApp14 - { _adobeDctVersion :: !Word16 - , _adobeFlag0 :: !Word16 - , _adobeFlag1 :: !Word16 - , _adobeTransform :: !AdobeTransform - } - deriving Show - -instance Binary AdobeTransform where - put v = case v of - AdobeUnknown -> putWord8 0 - AdobeYCbCr -> putWord8 1 - AdobeYCck -> putWord8 2 - - get = do - v <- getWord8 - pure $ case v of - 0 -> AdobeUnknown - 1 -> AdobeYCbCr - 2 -> AdobeYCck - _ -> AdobeUnknown - -instance Binary JpgAdobeApp14 where - get = do - let sig = BC.pack "Adobe" - fileSig <- getByteString 5 - when (fileSig /= sig) $ - fail "Invalid Adobe APP14 marker" - version <- getWord16be - when (version /= 100) $ - fail $ "Invalid Adobe APP14 version " ++ show version - JpgAdobeApp14 version - <$> getWord16be - <*> getWord16be <*> get - - put (JpgAdobeApp14 v f0 f1 t) = do - putByteString $ BC.pack "Adobe" - putWord16be v - putWord16be f0 - putWord16be f1 - put t - - -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 (JpgAdobeAPP14 _adobe) = return () -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 - -parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] -parseAdobe14 str lst = go where - go = case runGetStrict get str of - Left _err -> lst - Right app14 -> JpgAdobeAPP14 app14 : lst - -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 14 -> - parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame - 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 + 0xE0) - 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 - 0xE0) - | 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 +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Types( MutableMacroBlock + , createEmptyMutableMacroBlock + , printMacroBlock + , printPureMacroBlock + , DcCoefficient + , JpgImage( .. ) + , JpgComponent( .. ) + , JpgFrameHeader( .. ) + , JpgFrame( .. ) + , JpgFrameKind( .. ) + , JpgScanHeader( .. ) + , JpgQuantTableSpec( .. ) + , JpgHuffmanTableSpec( .. ) + , JpgImageKind( .. ) + , JpgScanSpecification( .. ) + , JpgColorSpace( .. ) + , AdobeTransform( .. ) + , JpgAdobeApp14( .. ) + , JpgJFIFApp0( .. ) + , JFifUnit( .. ) + , calculateSize + , dctBlockSize + ) where + + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +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.Char8 as BC +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 + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Jpg.DefaultTable +import Codec.Picture.Tiff.Types + +{-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 + | JpgAdobeAPP14 !JpgAdobeApp14 + | JpgJFIF !JpgJFIFApp0 + | JpgExif ![ImageFileDirectory] + | JpgExtension !Word8 B.ByteString + | JpgQuantTable ![JpgQuantTableSpec] + | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] + | JpgScanBlob !JpgScanHeader !L.ByteString + | JpgScans !JpgFrameKind !JpgFrameHeader + | JpgIntervalRestart !Word16 + deriving Show + +data JpgColorSpace + = JpgColorSpaceYCbCr + | JpgColorSpaceYCC + | JpgColorSpaceY + | JpgColorSpaceYA + | JpgColorSpaceYCCA + | JpgColorSpaceYCCK + | JpgColorSpaceCMYK + | JpgColorSpaceRGB + | JpgColorSpaceRGBA + deriving Show + +data AdobeTransform + = AdobeUnknown -- ^ Value 0 + | AdobeYCbCr -- ^ value 1 + | AdobeYCck -- ^ value 2 + deriving Show + +data JpgAdobeApp14 = JpgAdobeApp14 + { _adobeDctVersion :: !Word16 + , _adobeFlag0 :: !Word16 + , _adobeFlag1 :: !Word16 + , _adobeTransform :: !AdobeTransform + } + deriving Show + +-- | Size: 1 +data JFifUnit + = JFifUnitUnknown -- ^ 0 + | JFifPixelsPerInch -- ^ 1 + | JFifPixelsPerCentimeter -- ^ 2 + deriving Show + +instance Binary JFifUnit where + put v = putWord8 $ case v of + JFifUnitUnknown -> 0 + JFifPixelsPerInch -> 1 + JFifPixelsPerCentimeter -> 2 + get = do + v <- getWord8 + pure $ case v of + 0 -> JFifUnitUnknown + 1 -> JFifPixelsPerInch + 2 -> JFifPixelsPerCentimeter + _ -> JFifUnitUnknown + +data JpgJFIFApp0 = JpgJFIFApp0 + { _jfifUnit :: !JFifUnit + , _jfifDpiX :: !Word16 + , _jfifDpiY :: !Word16 + , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int) + } + deriving Show + +instance Binary JpgJFIFApp0 where + get = do + sig <- getByteString 5 + when (sig /= BC.pack "JFIF\0") $ + fail "Invalid JFIF signature" + major <- getWord8 + minor <- getWord8 + when (major /= 1 && minor > 2) $ + fail "Unrecognize JFIF version" + unit <- get + dpiX <- getWord16be + dpiY <- getWord16be + w <- getWord8 + h <- getWord8 + let pxCount = 3 * w * h + img <- case pxCount of + 0 -> return Nothing + _ -> return Nothing + return $ JpgJFIFApp0 + { _jfifUnit = unit + , _jfifDpiX = dpiX + , _jfifDpiY = dpiY + , _jfifThumbnail = img + } + + + put jfif = do + putByteString $ BC.pack "JFIF\0" -- 5 + putWord8 1 -- 1 6 + putWord8 2 -- 1 7 + put $ _jfifUnit jfif -- 1 8 + putWord16be $ _jfifDpiX jfif -- 2 10 + putWord16be $ _jfifDpiY jfif -- 2 12 + putWord8 0 -- 1 13 + putWord8 0 -- 1 14 + +{-Thumbnail width (tw) 1 Horizontal size of embedded JFIF thumbnail in pixels-} +{-Thumbnail height (th) 1 Vertical size of embedded JFIF thumbnail in pixels-} +{-Thumbnail data 3 × tw × th Uncompressed 24 bit RGB raster thumbnail-} + +instance Binary AdobeTransform where + put v = case v of + AdobeUnknown -> putWord8 0 + AdobeYCbCr -> putWord8 1 + AdobeYCck -> putWord8 2 + + get = do + v <- getWord8 + pure $ case v of + 0 -> AdobeUnknown + 1 -> AdobeYCbCr + 2 -> AdobeYCck + _ -> AdobeUnknown + +instance Binary JpgAdobeApp14 where + get = do + let sig = BC.pack "Adobe" + fileSig <- getByteString 5 + when (fileSig /= sig) $ + fail "Invalid Adobe APP14 marker" + version <- getWord16be + when (version /= 100) $ + fail $ "Invalid Adobe APP14 version " ++ show version + JpgAdobeApp14 version + <$> getWord16be + <*> getWord16be <*> get + + put (JpgAdobeApp14 v f0 f1 t) = do + putByteString $ BC.pack "Adobe" + putWord16be v + putWord16be f0 + putWord16be f1 + put t + + +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 (JpgAdobeAPP14 _adobe) = return () +putFrame (JpgJFIF jfif) = + put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif +putFrame (JpgExif _exif) = + return () -- TODO + {-put (JpgAppSegment 0) >> put exif-} +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 + +parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseAdobe14 str lst = go where + go = case runGetStrict get str of + Left _err -> lst + Right app14 -> JpgAdobeAPP14 app14 : lst + +-- | Parse JFIF or JFXX information. Right now only JFIF. +parseJF__ :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseJF__ str lst = go where + go = case runGetStrict get str of + Left _err -> lst + Right jfif -> JpgJFIF jfif : lst + +parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame] +parseExif str lst + | exifHeader `B.isPrefixOf` str = go + | otherwise = lst + where + exifHeader = BC.pack "Exif\0\0" + tiff = B.drop (B.length exifHeader) str + go = case runGetStrict (getP tiff) tiff of + Left _err -> lst + Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst + +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 0 -> + parseJF__ <$> takeCurrentFrame <*> parseNextFrame + JpgAppSegment 1 -> + parseExif <$> takeCurrentFrame <*> parseNextFrame + JpgAppSegment 14 -> + parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame + 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 + 0xE0) + 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 - 0xE0) + | 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/Metadata.hs b/src/Codec/Picture/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Metadata.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +-- | This module expose a common "metadata" storage for various image +-- type. Different format can generate different metadatas, and write +-- only a part of them. +-- +-- Since version 3.2.5 +-- +module Codec.Picture.Metadata( -- * Types + Metadatas + , Keys( .. ) + , Value( .. ) + , Elem( .. ) + + -- * Functions + , Codec.Picture.Metadata.lookup + , empty + , insert + , delete + , singleton + + -- * Folding + , foldl' + , Codec.Picture.Metadata.foldMap + + -- * Helper functions + , mkDpiMetadata + + -- * Conversion functions + , dotsPerMeterToDotPerInch + , dotPerInchToDotsPerMeter + , dotsPerCentiMeterToDotPerInch + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid, mempty, mappend ) +import Data.Word( Word ) +#endif + + +import Control.DeepSeq( NFData( .. ) ) +import qualified Data.Foldable as F + +import Codec.Picture.Metadata.Exif + +#if MIN_VERSION_base(4,7,0) +import Data.Typeable( (:~:)( Refl ) ) +type Equiv = (:~:) +#else +data Equiv a b where + Refl :: Equiv a a +#endif + +-- | Store various additional information about an image. If +-- something is not recognized, it can be stored in an unknown tag. +-- +-- * 'DpiX' Dot per inch on this x axis. +-- +-- * 'DpiY' Dot per inch on this y axis. +-- +-- * 'Unknown' unlikely to be decoded, but usefull for metadata writing +-- +-- * 'Exif' Exif tag and associated data. +-- +data Keys a where + Gamma :: Keys Double + DpiX :: Keys Word + DpiY :: Keys Word + Title :: Keys String + Description :: Keys String + Author :: Keys String + Copyright :: Keys String + Software :: Keys String + Comment :: Keys String + Disclaimer :: Keys String + Source :: Keys String + Warning :: Keys String + Exif :: !ExifTag -> Keys ExifData + Unknown :: !String -> Keys Value + +deriving instance Show (Keys a) +deriving instance Eq (Keys a) +{-deriving instance Ord (Keys a)-} + +-- | Encode values for unknown information +data Value + = Int !Int + | Double !Double + | String !String + deriving (Eq, Show) + +instance NFData Value where + rnf v = v `seq` () -- everything is strict, so it's OK + +-- | Element describing a metadata and it's (typed) associated +-- value. +data Elem k = + forall a. (Show a, NFData a) => !(k a) :=> a + +deriving instance Show (Elem Keys) + +instance NFData (Elem Keys) where + rnf (_ :=> v) = rnf v `seq` () + +keyEq :: Keys a -> Keys b -> Maybe (Equiv a b) +keyEq a b = case (a, b) of + (Gamma, Gamma) -> Just Refl + (DpiX, DpiX) -> Just Refl + (DpiY, DpiY) -> Just Refl + (Title, Title) -> Just Refl + (Description, Description) -> Just Refl + (Author, Author) -> Just Refl + (Copyright, Copyright) -> Just Refl + (Software, Software) -> Just Refl + (Comment, Comment) -> Just Refl + (Disclaimer, Disclaimer) -> Just Refl + (Source, Source) -> Just Refl + (Warning, Warning) -> Just Refl + (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl + (Exif t1, Exif t2) | t1 == t2 -> Just Refl + _ -> Nothing + +-- | Dependent storage used for metadatas. +-- All metadatas of a given kind are unique within +-- this container. + -- +-- The current data structure is based on list, +-- so bad performances can be expected. +newtype Metadatas = Metadatas + { getMetadatas :: [Elem Keys] + } + deriving (Show, NFData) + +instance Monoid Metadatas where + mempty = empty + mappend = union + +-- | Right based union +union :: Metadatas -> Metadatas -> Metadatas +union m1 = F.foldl' go m1 . getMetadatas where + go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc) + +-- | Strict left fold of the metadatas +foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc +foldl' f initAcc = F.foldl' f initAcc . getMetadatas + +-- | foldMap equivalent for metadatas. +foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m +foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty + +-- | Remove an element of the given keys from the metadatas. +-- If not present does nothing. +delete :: Keys a -> Metadatas -> Metadatas +delete k = Metadatas . go . getMetadatas where + go [] = [] + go (el@(k2 :=> _) : rest) = case keyEq k k2 of + Nothing -> el : go rest + Just Refl -> rest + +-- | Search a metadata with the given key. +lookup :: Keys a -> Metadatas -> Maybe a +lookup k = go . getMetadatas where + go [] = Nothing + go ((k2 :=> v) : rest) = case keyEq k k2 of + Nothing -> go rest + Just Refl -> Just v + +-- | Insert an element in the metadatas, if an element with +-- the same key is present, it is overwritten. +insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas +insert k val metas = + Metadatas $ (k :=> val) : getMetadatas (delete k metas) + +-- | Create metadatas with a single element. +singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas +singleton k val = Metadatas [k :=> val] + +-- | Empty metadatas. Favor 'mempty' +empty :: Metadatas +empty = Metadatas mempty + +-- | Conversion from dpm to dpi +dotsPerMeterToDotPerInch :: Word -> Word +dotsPerMeterToDotPerInch z = z * 254 `div` 10000 + +-- | Conversion from dpi to dpm +dotPerInchToDotsPerMeter :: Word -> Word +dotPerInchToDotsPerMeter z = (z * 10000) `div` 254 + +-- | Conversion dpcm -> dpi +dotsPerCentiMeterToDotPerInch :: Word -> Word +dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100 + +-- | Create metadatas indicating the resolution, with DpiX == DpiY +mkDpiMetadata :: Word -> Metadatas +mkDpiMetadata w = insert DpiY w $ singleton DpiX w + diff --git a/src/Codec/Picture/Metadata/Exif.hs b/src/Codec/Picture/Metadata/Exif.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Metadata/Exif.hs @@ -0,0 +1,205 @@ +-- | This module provide a totally partial and incomplete maping +-- of Exif values. Used for Tiff parsing and reused for Exif extraction. +module Codec.Picture.Metadata.Exif ( ExifTag( .. ) + , ExifData( .. ) + + , tagOfWord16 + , word16OfTag + ) where + +import Control.DeepSeq( NFData( .. ) ) +import Data.Int( Int32 ) +import Data.Word( Word16, Word32 ) +import qualified Data.Vector as V +import qualified Data.ByteString as B + +-- | Tag values used for exif fields. Completly incomplete +data ExifTag + = 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 + | TagPredictor + | TagCopyright + | TagMake + | TagModel + | TagDateTime + | TagGPSInfo + + | TagJpegProc + | TagJPEGInterchangeFormat + | TagJPEGInterchangeFormatLength + | TagJPEGRestartInterval + | TagJPEGLosslessPredictors + | TagJPEGPointTransforms + | TagJPEGQTables + | TagJPEGDCTables + | TagJPEGACTables + + | TagExifOffset + | TagUnknown !Word16 + deriving (Eq, Ord, Show) + +-- | Convert a value to it's corresponding Exif tag. +-- Will often be written as 'TagUnknown' +tagOfWord16 :: Word16 -> ExifTag +tagOfWord16 v = case v of + 255 -> TagSubfileType + 256 -> TagImageWidth + 257 -> TagImageLength + 258 -> TagBitsPerSample + 259 -> TagCompression + 262 -> TagPhotometricInterpretation + 266 -> TagFillOrder + 269 -> TagDocumentName + 270 -> TagImageDescription + 271 -> TagMake + 272 -> TagModel + 273 -> TagStripOffsets + 274 -> TagOrientation + 277 -> TagSamplesPerPixel + 278 -> TagRowPerStrip + 279 -> TagStripByteCounts + 282 -> TagXResolution + 283 -> TagYResolution + 284 -> TagPlanarConfiguration + 286 -> TagXPosition + 287 -> TagYPosition + 296 -> TagResolutionUnit + 305 -> TagSoftware + 306 -> TagDateTime + 315 -> TagArtist + 317 -> TagPredictor + 320 -> TagColorMap + 322 -> TagTileWidth + 323 -> TagTileLength + 324 -> TagTileOffset + 325 -> TagTileByteCount + 332 -> TagInkSet + 338 -> TagExtraSample + 339 -> TagSampleFormat + 529 -> TagYCbCrCoeff + 512 -> TagJpegProc + 513 -> TagJPEGInterchangeFormat + 514 -> TagJPEGInterchangeFormatLength + 515 -> TagJPEGRestartInterval + 517 -> TagJPEGLosslessPredictors + 518 -> TagJPEGPointTransforms + 519 -> TagJPEGQTables + 520 -> TagJPEGDCTables + 521 -> TagJPEGACTables + 530 -> TagYCbCrSubsampling + 531 -> TagYCbCrPositioning + 532 -> TagReferenceBlackWhite + 33432 -> TagCopyright + 34665 -> TagExifOffset + 34853 -> TagGPSInfo + vv -> TagUnknown vv + +-- | Convert a tag to it's corresponding value. +word16OfTag :: ExifTag -> Word16 +word16OfTag t = case t of + TagSubfileType -> 255 + TagImageWidth -> 256 + TagImageLength -> 257 + TagBitsPerSample -> 258 + TagCompression -> 259 + TagPhotometricInterpretation -> 262 + TagFillOrder -> 266 + TagDocumentName -> 269 + TagImageDescription -> 270 + TagMake -> 271 + TagModel -> 272 + TagStripOffsets -> 273 + TagOrientation -> 274 + TagSamplesPerPixel -> 277 + TagRowPerStrip -> 278 + TagStripByteCounts -> 279 + TagXResolution -> 282 + TagYResolution -> 283 + TagPlanarConfiguration -> 284 + TagXPosition -> 286 + TagYPosition -> 287 + TagResolutionUnit -> 296 + TagSoftware -> 305 + TagDateTime -> 306 + TagArtist -> 315 + TagPredictor -> 317 + TagColorMap -> 320 + TagTileWidth -> 322 + TagTileLength -> 323 + TagTileOffset -> 324 + TagTileByteCount -> 325 + TagInkSet -> 332 + TagExtraSample -> 338 + TagSampleFormat -> 339 + TagYCbCrCoeff -> 529 + TagJpegProc -> 512 + TagJPEGInterchangeFormat -> 513 + TagJPEGInterchangeFormatLength -> 514 + TagJPEGRestartInterval -> 515 + TagJPEGLosslessPredictors -> 517 + TagJPEGPointTransforms -> 518 + TagJPEGQTables -> 519 + TagJPEGDCTables -> 520 + TagJPEGACTables -> 521 + TagYCbCrSubsampling -> 530 + TagYCbCrPositioning -> 531 + TagReferenceBlackWhite -> 532 + TagCopyright -> 33432 + TagExifOffset -> 34665 + TagGPSInfo -> 34853 + (TagUnknown v) -> v + +-- | Possible data held by an Exif tag +data ExifData + = ExifNone + | ExifLong !Word32 + | ExifShort !Word16 + | ExifString !B.ByteString + | ExifUndefined !B.ByteString + | ExifShorts !(V.Vector Word16) + | ExifLongs !(V.Vector Word32) + | ExifRational !Word32 !Word32 + | ExifSignedRational !Int32 !Int32 + | ExifIFD ![(ExifTag, ExifData)] + deriving Show + +instance NFData ExifTag where + rnf a = a `seq` () + +instance NFData ExifData where + rnf (ExifIFD ifds) = rnf ifds `seq` () + rnf (ExifLongs l) = rnf l `seq` () + rnf (ExifShorts l) = rnf l `seq` () + rnf a = a `seq` () diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs --- a/src/Codec/Picture/Png.hs +++ b/src/Codec/Picture/Png.hs @@ -3,6 +3,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) -- files. @@ -19,11 +20,12 @@ PngSavable( .. ) , decodePng + , decodePngWithMetadata , writePng - , encodePalettedPng , encodeDynamicPng + , encodePalettedPng + , encodePalettedPngWithMetadata , writeDynamicPng - ) where #if !MIN_VERSION_base(4,8,0) @@ -46,8 +48,10 @@ import Foreign.Storable ( Storable ) import Codec.Picture.Types +import Codec.Picture.Metadata import Codec.Picture.Png.Type import Codec.Picture.Png.Export +import Codec.Picture.Png.Metadata import Codec.Picture.InternalHelper -- | Simple structure used to hold information about Adam7 deinterlacing. @@ -425,7 +429,7 @@ | otherwise = 255] unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType - -> B.ByteString -> Either [Char] DynamicImage + -> B.ByteString -> Either String DynamicImage unparse ihdr _ t PngGreyscale bytes | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes @@ -456,7 +460,7 @@ h = fromIntegral $ height hdr palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t - -> Either [Char] DynamicImage + -> Either String DynamicImage palette8 hdr palette transparency eimg = case (transparency, eimg) of ([c], Left img) -> Right . ImageRGBA8 . Image w h @@ -495,30 +499,40 @@ -- * PixelRGBA16 -- decodePng :: B.ByteString -> Either String DynamicImage -decodePng byte = do - rawImg <- runGetStrict get byte - let ihdr = 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-} +decodePng = fmap fst . decodePngWithMetadata - transparencyColor = - [ chunkData chunk | chunk <- chunks rawImg - , chunkType chunk == tRNSSignature ] +-- | Same as 'decodePng' but also extract meta datas present +-- in the files. +decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodePngWithMetadata byte = do + rawImg <- runGetStrict get byte + let ihdr = header rawImg + metadatas = extractMetadatas 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-} + transparencyColor = + [ chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == tRNSSignature ] - 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 ihdr palette transparencyColor (colourType ihdr) parseableData + + if Lb.length compressedImageData <= zlibHeaderSize then + Left "Invalid data size" + else + let imgData = Z.decompress compressedImageData + parseableData = B.concat $ Lb.toChunks imgData + palette = do + p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg + case parsePalette p of + Left _ -> Nothing + Right plte -> return plte + in + (, metadatas) <$> + unparse ihdr palette transparencyColor (colourType ihdr) parseableData + +{-# ANN module "HLint: ignore Reduce duplication" #-} diff --git a/src/Codec/Picture/Png/Export.hs b/src/Codec/Picture/Png/Export.hs --- a/src/Codec/Picture/Png/Export.hs +++ b/src/Codec/Picture/Png/Export.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} @@ -9,12 +10,17 @@ , encodeDynamicPng , writeDynamicPng , encodePalettedPng + , encodePalettedPngWithMetadata ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +#endif import Control.Monad( forM_ ) import Control.Monad.ST( ST, runST ) import Data.Bits( unsafeShiftR, (.&.) ) import Data.Binary( encode ) +import Data.Monoid( (<>) ) import Data.Word(Word8, Word16) import qualified Codec.Compression.Zlib as Z import qualified Data.ByteString as B @@ -25,6 +31,8 @@ import Codec.Picture.Types import Codec.Picture.Png.Type +import Codec.Picture.Png.Metadata +import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.VectorByteConversion( blitVector, toByteString ) -- | Encode an image into a png if possible. @@ -32,43 +40,63 @@ -- | Transform an image into a png encoded bytestring, ready -- to be written as a file. encodePng :: Image a -> Lb.ByteString + encodePng = encodePngWithMetadata mempty + -- | Encode a png using some metadatas. The following metadata keys will + -- be stored in a `tEXt` field : + -- + -- * 'Codec.Picture.Metadata.Title' + -- * 'Codec.Picture.Metadata.Description' + -- * 'Codec.Picture.Metadata.Author' + -- * 'Codec.Picture.Metadata.Copyright' + -- * 'Codec.Picture.Metadata.Software' + -- * 'Codec.Picture.Metadata.Comment' + -- * 'Codec.Picture.Metadata.Disclaimer' + -- * 'Codec.Picture.Metadata.Source' + -- * 'Codec.Picture.Metadata.Warning' + -- * 'Codec.Picture.Metadata.Unknown' using the key present in the constructor. + -- + -- the followings metadata will bes tored in the `gAMA` chunk. + -- + -- * 'Codec.Picture.Metadata.Gamma' + -- + -- The followings metadata will be stored in a `pHYs` chunk + -- + -- * 'Codec.Picture.Metadata.DpiX' + -- * 'Codec.Picture.Metadata.DpiY' + encodePngWithMetadata :: Metadatas -> 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 - } + { 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 - } - +endChunk = mkRawChunk iENDSignature mempty prepareIDatChunk :: Lb.ByteString -> PngRawChunk -prepareIDatChunk imgData = PngRawChunk - { chunkLength = fromIntegral $ Lb.length imgData - , chunkType = iDATSignature - , chunkCRC = pngComputeCrc [iDATSignature, imgData] - , chunkData = imgData - } +prepareIDatChunk = mkRawChunk iDATSignature genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) - => PngImageType -> Image px -> Lb.ByteString -genericEncode16BitsPng imgKind + => PngImageType -> Metadatas -> Image px -> Lb.ByteString +genericEncode16BitsPng imgKind metas image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = - encode PngRawImage { header = hdr, chunks = [prepareIDatChunk imgEncodedData, endChunk]} + encode PngRawImage { header = hdr + , chunks = encodeMetadatas metas + <> [ prepareIDatChunk imgEncodedData + , endChunk + ] + } where hdr = preparePngHeader image imgKind 16 zero = B.singleton 0 compCount = componentCount (undefined :: px) @@ -101,12 +129,15 @@ where binaryData = Lb.fromChunks [toByteString $ imageData pal] genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) - => Maybe Palette -> PngImageType -> Image px + => Maybe Palette -> PngImageType -> Metadatas -> Image px -> Lb.ByteString -genericEncodePng palette imgKind +genericEncodePng palette imgKind metas image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = encode PngRawImage { header = hdr - , chunks = prependPalette palette [prepareIDatChunk imgEncodedData, endChunk]} + , chunks = encodeMetadatas metas + <> prependPalette palette + [ prepareIDatChunk imgEncodedData + , endChunk]} where hdr = preparePngHeader image imgKind 8 zero = B.singleton 0 compCount = componentCount (undefined :: px) @@ -120,28 +151,28 @@ $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] instance PngSavable PixelRGBA8 where - encodePng = genericEncodePng Nothing PngTrueColourWithAlpha + encodePngWithMetadata = genericEncodePng Nothing PngTrueColourWithAlpha instance PngSavable PixelRGB8 where - encodePng = genericEncodePng Nothing PngTrueColour + encodePngWithMetadata = genericEncodePng Nothing PngTrueColour instance PngSavable Pixel8 where - encodePng = genericEncodePng Nothing PngGreyscale + encodePngWithMetadata = genericEncodePng Nothing PngGreyscale instance PngSavable PixelYA8 where - encodePng = genericEncodePng Nothing PngGreyscaleWithAlpha + encodePngWithMetadata = genericEncodePng Nothing PngGreyscaleWithAlpha instance PngSavable PixelYA16 where - encodePng = genericEncode16BitsPng PngGreyscaleWithAlpha + encodePngWithMetadata = genericEncode16BitsPng PngGreyscaleWithAlpha instance PngSavable Pixel16 where - encodePng = genericEncode16BitsPng PngGreyscale + encodePngWithMetadata = genericEncode16BitsPng PngGreyscale instance PngSavable PixelRGB16 where - encodePng = genericEncode16BitsPng PngTrueColour + encodePngWithMetadata = genericEncode16BitsPng PngTrueColour instance PngSavable PixelRGBA16 where - encodePng = genericEncode16BitsPng PngTrueColourWithAlpha + encodePngWithMetadata = genericEncode16BitsPng PngTrueColourWithAlpha -- | Write a dynamic image in a .png image file if possible. -- The same restriction as encodeDynamicPng apply. @@ -153,11 +184,15 @@ -- | 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 +encodePalettedPng = encodePalettedPngWithMetadata mempty + +-- | Equivalent to 'encodePalettedPng' but allow writing of metadatas. +encodePalettedPngWithMetadata :: Metadatas -> Palette -> Image Pixel8 -> Either String Lb.ByteString +encodePalettedPngWithMetadata metas 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 + | otherwise = Right $ genericEncodePng (Just pal) PngIndexedColor metas img where w = imageWidth pal h = imageHeight pal isTooBig v = fromIntegral v >= w diff --git a/src/Codec/Picture/Png/Metadata.hs b/src/Codec/Picture/Png/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Png/Metadata.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Codec.Picture.Png.Metadata( extractMetadatas + , encodeMetadatas + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( Monoid, mempty ) +import Data.Foldable( foldMap ) +#endif + +import Data.Maybe( fromMaybe ) +import Data.Binary( Binary( get, put ), encode ) +import Data.Binary.Get( getLazyByteStringNul ) +import Data.Binary.Put( putLazyByteString, putWord8 ) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Monoid( (<>) ) + +import Codec.Picture.InternalHelper +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata ( Metadatas + , dotsPerMeterToDotPerInch + , Elem( (:=>) ) ) +import Codec.Picture.Png.Type + +#if !MIN_VERSION_base(4,7,0) +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap f v = case v of + Left _ -> mempty + Right a -> f a +#else +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap = foldMap +#endif + +getGamma :: [L.ByteString] -> Metadatas +getGamma [] = mempty +getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g + where + unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma) + +getDpis :: [L.ByteString] -> Metadatas +getDpis [] = mempty +getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b + where + unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } = + Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72 + unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } = + Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy + where + dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy + dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy + +data PngText = PngText + { pngKeyword :: !L.ByteString + , pngData :: !L.ByteString + } + deriving Show + +instance Binary PngText where + get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes + put (PngText kw pdata) = do + putLazyByteString kw + putWord8 0 + putLazyByteString pdata + +textToMetadata :: PngText -> Metadatas +textToMetadata ptext = case pngKeyword ptext of + "Title" -> strValue Met.Title + "Author" -> strValue Met.Author + "Description" -> strValue Met.Description + "Copyright" -> strValue Met.Copyright + {-"Creation Time" -> strValue Creation-} + "Software" -> strValue Met.Software + "Disclaimer" -> strValue Met.Disclaimer + "Warning" -> strValue Met.Warning + "Source" -> strValue Met.Source + "Comment" -> strValue Met.Comment + other -> + Met.singleton + (Met.Unknown $ L.unpack other) + (Met.String . L.unpack $ pngData ptext) + where + strValue k = Met.singleton k . L.unpack $ pngData ptext + +getTexts :: [L.ByteString] -> Metadatas +getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where + + +extractMetadatas :: PngRawImage -> Metadatas +extractMetadatas img = getDpis (chunksOf pHYsSignature) + <> getGamma (chunksOf gammaSignature) + <> getTexts (chunksOf tEXtSignature) + where + chunksOf = chunksWithSig img + +encodePhysicalMetadata :: Metadatas -> [PngRawChunk] +encodePhysicalMetadata metas = fromMaybe [] $ do + dx <- Met.lookup Met.DpiX metas + dy <- Met.lookup Met.DpiY metas + let to = fromIntegral . Met.dotPerInchToDotsPerMeter + dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter + pure [mkRawChunk pHYsSignature $ encode dim] + +encodeSingleMetadata :: Metadatas -> [PngRawChunk] +encodeSingleMetadata = Met.foldMap go where + go :: Elem Met.Keys -> [PngRawChunk] + go v = case v of + Met.Exif _ :=> _ -> mempty + Met.DpiX :=> _ -> mempty + Met.DpiY :=> _ -> mempty + Met.Gamma :=> g -> + pure $ mkRawChunk gammaSignature . encode $ PngGamma g + Met.Title :=> tx -> txt "Title" (L.pack tx) + Met.Description :=> tx -> txt "Description" (L.pack tx) + Met.Author :=> tx -> txt "Author" (L.pack tx) + Met.Copyright :=> tx -> txt "Copyright" (L.pack tx) + Met.Software :=> tx -> txt "Software" (L.pack tx) + Met.Comment :=> tx -> txt "Comment" (L.pack tx) + Met.Disclaimer :=> tx -> txt "Disclaimer" (L.pack tx) + Met.Source :=> tx -> txt "Source" (L.pack tx) + Met.Warning :=> tx -> txt "Warning" (L.pack tx) + Met.Unknown k :=> Met.String tx -> txt (L.pack k) (L.pack tx) + Met.Unknown _ :=> _ -> mempty + + txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c + +encodeMetadatas :: Metadatas -> [PngRawChunk] +encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m + diff --git a/src/Codec/Picture/Png/Type.hs b/src/Codec/Picture/Png/Type.hs --- a/src/Codec/Picture/Png/Type.hs +++ b/src/Codec/Picture/Png/Type.hs @@ -5,6 +5,9 @@ , PngInterlaceMethod( .. ) , PngPalette , PngImageType( .. ) + , PngPhysicalDimension( .. ) + , PngGamma( .. ) + , PngUnit( .. ) , APngAnimationControl( .. ) , APngFrameDisposal( .. ) , APngBlendOp( .. ) @@ -15,7 +18,10 @@ , iDATSignature , iENDSignature , tRNSSignature + , tEXtSignature + , zTXtSignature , gammaSignature + , pHYsSignature , animationControlSignature -- * Low level types , ChunkSignature @@ -23,10 +29,12 @@ , PngChunk( .. ) , PngRawChunk( .. ) , PngLowLevel( .. ) + , chunksWithSig + , mkRawChunk ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) +import Control.Applicative( (<$>), (<*>), pure ) #endif import Control.Monad( when, replicateM ) @@ -70,6 +78,39 @@ } deriving Show +data PngUnit + = PngUnitUnknown -- ^ 0 value + | PngUnitMeter -- ^ 1 value + +instance Binary PngUnit where + get = do + v <- getWord8 + pure $ case v of + 0 -> PngUnitUnknown + 1 -> PngUnitMeter + _ -> PngUnitUnknown + + put v = case v of + PngUnitUnknown -> putWord8 0 + PngUnitMeter -> putWord8 1 + +data PngPhysicalDimension = PngPhysicalDimension + { pngDpiX :: !Word32 + , pngDpiY :: !Word32 + , pngUnit :: !PngUnit + } + +instance Binary PngPhysicalDimension where + get = PngPhysicalDimension <$> getWord32be <*> getWord32be <*> get + put (PngPhysicalDimension dpx dpy unit) = + putWord32be dpx >> putWord32be dpy >> put unit + +newtype PngGamma = PngGamma { getPngGamma :: Double } + +instance Binary PngGamma where + get = PngGamma . (/ 100000) . fromIntegral <$> getWord32be + put = putWord32be . ceiling . (100000 *) . getPngGamma + data APngAnimationControl = APngAnimationControl { animationFrameCount :: !Word32 , animationPlayCount :: !Word32 @@ -149,6 +190,14 @@ , chunkData :: L.ByteString } +mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk +mkRawChunk sig binaryData = PngRawChunk + { chunkLength = fromIntegral $ L.length binaryData + , chunkType = sig + , chunkCRC = pngComputeCrc [sig, binaryData] + , chunkData = binaryData + } + -- | PNG chunk representing some extra information found in the parsed file. data PngChunk = PngChunk { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk @@ -349,6 +398,15 @@ gammaSignature :: ChunkSignature gammaSignature = signature "gAMA" +pHYsSignature :: ChunkSignature +pHYsSignature = signature "pHYs" + +tEXtSignature :: ChunkSignature +tEXtSignature = signature "tEXt" + +zTXtSignature :: ChunkSignature +zTXtSignature = signature "zTXt" + animationControlSignature :: ChunkSignature animationControlSignature = signature "acTL" @@ -385,4 +443,8 @@ let u32Val = fromIntegral val lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) in lutVal `xor` (crc `unsafeShiftR` 8) + +chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString] +chunksWithSig rawImg sig = + [chunkData chunk | chunk <- chunks rawImg, chunkType chunk == sig] diff --git a/src/Codec/Picture/Tga.hs b/src/Codec/Picture/Tga.hs --- a/src/Codec/Picture/Tga.hs +++ b/src/Codec/Picture/Tga.hs @@ -1,508 +1,509 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} --- | Module implementing function to read and write --- Targa (*.tga) files. -module Codec.Picture.Tga( decodeTga - , TgaSaveable - , encodeTga - , writeTga - ) where - - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid( mempty ) -import Control.Applicative( (<*>), pure, (<$>) ) -#endif - -import Control.Monad.ST( ST, runST ) -import Data.Bits( (.&.) - , (.|.) - , bit - , testBit - , setBit - , unsafeShiftL - , unsafeShiftR ) -import Data.Word( Word8, Word16 ) -import Data.Binary( Binary( .. ), encode ) -import Data.Binary.Get( Get - , getByteString - , getWord8 - , getWord16le - ) -import Data.Binary.Put( putWord8 - , putWord16le - , putByteString - ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as Lb -import qualified Data.ByteString.Unsafe as U -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Types -import Codec.Picture.InternalHelper -import Codec.Picture.VectorByteConversion - -data TgaColorMapType - = ColorMapWithoutTable - | ColorMapWithTable - | ColorMapUnknown Word8 - -instance Binary TgaColorMapType where - get = do - v <- getWord8 - return $ case v of - 0 -> ColorMapWithoutTable - 1 -> ColorMapWithTable - n -> ColorMapUnknown n - - put v = case v of - ColorMapWithoutTable -> putWord8 0 - ColorMapWithTable -> putWord8 1 - (ColorMapUnknown vv) -> putWord8 vv - -data TgaImageType - = ImageTypeNoData Bool - | ImageTypeColorMapped Bool - | ImageTypeTrueColor Bool - | ImageTypeMonochrome Bool - -isRleEncoded :: TgaImageType -> Bool -isRleEncoded v = case v of - ImageTypeNoData yn -> yn - ImageTypeColorMapped yn -> yn - ImageTypeTrueColor yn -> yn - ImageTypeMonochrome yn -> yn - -imageTypeOfCode :: Monad m => Word8 -> m TgaImageType -imageTypeOfCode v = case v .&. 3 of - 0 -> return $ ImageTypeNoData isEncoded - 1 -> return $ ImageTypeColorMapped isEncoded - 2 -> return $ ImageTypeTrueColor isEncoded - 3 -> return $ ImageTypeMonochrome isEncoded - _ -> fail $ "Unknown TGA image type " ++ show v - where - isEncoded = testBit v 3 - -codeOfImageType :: TgaImageType -> Word8 -codeOfImageType v = case v of - ImageTypeNoData encoded -> setVal 0 encoded - ImageTypeColorMapped encoded -> setVal 1 encoded - ImageTypeTrueColor encoded -> setVal 2 encoded - ImageTypeMonochrome encoded -> setVal 3 encoded - where - setVal vv True = setBit vv 3 - setVal vv False = vv - -instance Binary TgaImageType where - get = getWord8 >>= imageTypeOfCode - put = putWord8 . codeOfImageType - -data TgaImageDescription = TgaImageDescription - { _tgaIdXOrigin :: Bool - , _tgaIdYOrigin :: Bool - , _tgaIdAttributeBits :: Word8 - } - -instance Binary TgaImageDescription where - put desc = putWord8 $ xOrig .|. yOrig .|. attr - where - xOrig | _tgaIdXOrigin desc = bit 4 - | otherwise = 0 - - yOrig | not $ _tgaIdYOrigin desc = bit 5 - | otherwise = 0 - - attr = _tgaIdAttributeBits desc .&. 0xF - - get = toDescr <$> getWord8 where - toDescr v = TgaImageDescription - { _tgaIdXOrigin = testBit v 4 - , _tgaIdYOrigin = not $ testBit v 5 - , _tgaIdAttributeBits = v .&. 0xF - } - -data TgaHeader = TgaHeader - { _tgaHdrIdLength :: {-# UNPACK #-} !Word8 - , _tgaHdrColorMapType :: !TgaColorMapType - , _tgaHdrImageType :: !TgaImageType - , _tgaHdrMapStart :: {-# UNPACK #-} !Word16 - , _tgaHdrMapLength :: {-# UNPACK #-} !Word16 - , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8 - , _tgaHdrXOffset :: {-# UNPACK #-} !Word16 - , _tgaHdrYOffset :: {-# UNPACK #-} !Word16 - , _tgaHdrWidth :: {-# UNPACK #-} !Word16 - , _tgaHdrHeight :: {-# UNPACK #-} !Word16 - , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8 - , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription - } - -instance Binary TgaHeader where - get = TgaHeader - <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8 - <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get - where g16 = getWord16le - g8 = getWord8 - - put v = do - let p8 = putWord8 - p16 = putWord16le - p8 $ _tgaHdrIdLength v - put $ _tgaHdrColorMapType v - put $ _tgaHdrImageType v - - p16 $ _tgaHdrMapStart v - p16 $ _tgaHdrMapLength v - p8 $ _tgaHdrMapDepth v - p16 $ _tgaHdrXOffset v - p16 $ _tgaHdrYOffset v - p16 $ _tgaHdrWidth v - p16 $ _tgaHdrHeight v - p8 $ _tgaHdrPixelDepth v - put $ _tgaHdrImageDescription v - - -data TgaFile = TgaFile - { _tgaFileHeader :: !TgaHeader - , _tgaFileId :: !B.ByteString - , _tgaPalette :: !B.ByteString - , _tgaFileRest :: !B.ByteString - } - -getPalette :: TgaHeader -> Get B.ByteString -getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty -getPalette hdr = getByteString $ bytePerPixel * pixelCount - where - bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8 - pixelCount = fromIntegral $ _tgaHdrMapLength hdr - -instance Binary TgaFile where - get = do - hdr <- get - validateTga hdr - fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr - palette <- getPalette hdr - rest <- getRemainingBytes - - return TgaFile { - _tgaFileHeader = hdr - , _tgaFileId = fileId - , _tgaPalette = palette - , _tgaFileRest = rest - } - - put file = do - put $ _tgaFileHeader file - putByteString $ _tgaFileId file - putByteString $ _tgaPalette file - putByteString $ _tgaFileRest file - -data Depth8 = Depth8 -data Depth15 = Depth15 -data Depth24 = Depth24 -data Depth32 = Depth32 - -class (Pixel (Unpacked a)) => TGAPixel a where - type Unpacked a - packedByteSize :: a -> Int - tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a - -instance TGAPixel Depth8 where - type Unpacked Depth8 = Pixel8 - packedByteSize _ = 1 - tgaUnpack _ = U.unsafeIndex - -instance TGAPixel Depth15 where - type Unpacked Depth15 = PixelRGBA8 - packedByteSize _ = 2 - tgaUnpack _ str ix = PixelRGBA8 r g b a - where - v0 = U.unsafeIndex str ix - v1 = U.unsafeIndex str $ ix + 1 - r = (v1 .&. 0x7c) `unsafeShiftL` 1; - g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2); - b = (v0 .&. 0x1f) `unsafeShiftL` 3 - a = 255 -- v1 .&. 0x80 - -instance TGAPixel Depth24 where - type Unpacked Depth24 = PixelRGB8 - packedByteSize _ = 3 - tgaUnpack _ str ix = PixelRGB8 r g b - where - b = U.unsafeIndex str ix - g = U.unsafeIndex str (ix + 1) - r = U.unsafeIndex str (ix + 2) - -instance TGAPixel Depth32 where - type Unpacked Depth32 = PixelRGBA8 - packedByteSize _ = 4 - tgaUnpack _ str ix = PixelRGBA8 r g b a - where - b = U.unsafeIndex str ix - g = U.unsafeIndex str (ix + 1) - r = U.unsafeIndex str (ix + 2) - a = 255 - U.unsafeIndex str (ix + 3) - -prepareUnpacker :: TgaFile - -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx)) - -> Either String DynamicImage -prepareUnpacker file f = - let hdr = _tgaFileHeader file - flipper :: (Pixel px) => Image px -> Image px - flipper = flipImage $ _tgaHdrImageDescription hdr - in - case _tgaHdrPixelDepth hdr of - 8 -> pure . ImageY8 . flipper $ f Depth8 file - 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file - 24 -> pure . ImageRGB8 . flipper $ f Depth24 file - 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file - n -> fail $ "Invalid bit depth (" ++ show n ++ ")" - -applyPalette :: (Pixel px) - => (Image px -> DynamicImage) -> Image px - -> DynamicImage - -> Either String DynamicImage -applyPalette f palette (ImageY8 img) = - pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img -applyPalette _ _ _ = - fail "Bad colorspace for image" - -unparse :: TgaFile -> Either String DynamicImage -unparse file = - let hdr = _tgaFileHeader file - imageType = _tgaHdrImageType hdr - - unpacker :: forall tgapx. (TGAPixel tgapx) - => tgapx -> TgaFile -> Image (Unpacked tgapx) - unpacker | isRleEncoded imageType = unpackRLETga - | otherwise = unpackUncompressedTga - - decodedPalette = unparse file - { _tgaFileHeader = hdr - { _tgaHdrHeight = 1 - , _tgaHdrWidth = _tgaHdrMapLength hdr - , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr - , _tgaHdrImageType = ImageTypeTrueColor False - } - , _tgaFileRest = _tgaPalette file - } - in - case imageType of - ImageTypeNoData _ -> fail "No data detected in TGA file" - ImageTypeTrueColor _ -> - prepareUnpacker file unpacker - ImageTypeMonochrome _ -> - prepareUnpacker file unpacker - ImageTypeColorMapped _ -> - case decodedPalette of - Left str -> Left str - Right (ImageY8 img) -> - prepareUnpacker file unpacker >>= applyPalette ImageY8 img - Right (ImageRGB8 img) -> - prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img - Right (ImageRGBA8 img) -> - prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img - Right _ -> fail "Unknown pixel type" - -writeRun :: (Pixel px) - => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int - -> ST s Int -writeRun imgData localMaxi px = run - where - writeDelta = componentCount px - run writeIndex - | writeIndex >= localMaxi = return writeIndex - run writeIndex = do - unsafeWritePixel imgData writeIndex px - run $ writeIndex + writeDelta - -copyData :: forall tgapx s - . (TGAPixel tgapx) - => tgapx - -> M.STVector s (PixelBaseComponent (Unpacked tgapx)) - -> B.ByteString - -> Int -> Int - -> Int -> Int - -> ST s (Int, Int) -copyData tgapx imgData readData maxi maxRead = go - where - readDelta = packedByteSize tgapx - writeDelta = componentCount (undefined :: Unpacked tgapx) - - go writeIndex readIndex - | writeIndex >= maxi || - readIndex >= maxRead = return (writeIndex, readIndex) - go writeIndex readIndex = do - let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx - unsafeWritePixel imgData writeIndex px - go (writeIndex + writeDelta) (readIndex + readDelta) - -unpackUncompressedTga :: forall tgapx - . (TGAPixel tgapx) - => tgapx -- ^ Type witness - -> TgaFile - -> Image (Unpacked tgapx) -unpackUncompressedTga tga file = runST $ do - img <- MutableImage width height <$> M.new maxi - let imgData = mutableImageData img - _ <- copyData tga imgData readData maxi maxRead 0 0 - unsafeFreezeImage img - - where - hdr = _tgaFileHeader file - width = fromIntegral $ _tgaHdrWidth hdr - height = fromIntegral $ _tgaHdrHeight hdr - readData = _tgaFileRest file - compCount = componentCount (undefined :: Unpacked tgapx) - maxi = width * height * compCount - maxRead = B.length readData - -isRleChunk :: Word8 -> Bool -isRleChunk v = testBit v 7 - -runLength :: Word8 -> Int -runLength v = fromIntegral (v .&. 0x7F) + 1 - -unpackRLETga :: forall tgapx - . (TGAPixel tgapx) - => tgapx -- ^ Type witness - -> TgaFile - -> Image (Unpacked tgapx) -unpackRLETga tga file = runST $ do - img <- MutableImage width height <$> M.new maxi - let imgData = mutableImageData img - - go writeIndex readIndex - | writeIndex >= maxi = return () - | readIndex >= maxRead = return () - go writeIndex readIndex = do - let code = U.unsafeIndex readData readIndex - copyMax = min maxi $ writeIndex + runLength code * compCount - - if isRleChunk code then do - let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx - lastWriteIndex <- writeRun imgData copyMax px writeIndex - go lastWriteIndex $ readIndex + 1 + readDelta - - else do - (newWrite, newRead) <- - copyData tga imgData readData copyMax maxRead - writeIndex (readIndex + 1) - go newWrite newRead - - go 0 0 - unsafeFreezeImage img - - where - hdr = _tgaFileHeader file - width = fromIntegral $ _tgaHdrWidth hdr - height = fromIntegral $ _tgaHdrHeight hdr - readData = _tgaFileRest file - compCount = componentCount (undefined :: Unpacked tgapx) - maxi = width * height * compCount - maxRead = B.length readData - readDelta = packedByteSize tga - -flipImage :: (Pixel px) - => TgaImageDescription -> Image px -> Image px -flipImage desc img - | xFlip && yFlip = - generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h - | xFlip = - generateImage (\x y -> pixelAt img (wMax - x) y) w h - | yFlip = - generateImage (\x y -> pixelAt img x (hMax - y)) w h - | otherwise = img - where - xFlip = _tgaIdXOrigin desc - yFlip = _tgaIdYOrigin desc - w = imageWidth img - h = imageHeight img - - !wMax = w - 1 - !hMax = h - 1 - -validateTga :: (Monad m) => TgaHeader -> m () -validateTga hdr - | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative" - | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative" -validateTga _ = return () - --- | Transform a raw tga image to an image, without modifying --- the underlying pixel type. --- --- This function can output the following pixel types: --- --- * PixelY8 --- --- * PixelRGB8 --- --- * PixelRGBA8 --- -decodeTga :: B.ByteString -> Either String DynamicImage -decodeTga byte = runGetStrict get byte >>= unparse - --- | This typeclass determine if a pixel can be saved in the --- TGA format. -class TgaSaveable a where - tgaDataOfImage :: Image a -> B.ByteString - tgaPixelDepthOfImage :: Image a -> Word8 - tgaTypeOfImage :: Image a -> TgaImageType - -instance TgaSaveable Pixel8 where - tgaDataOfImage = toByteString . imageData - tgaPixelDepthOfImage _ = 8 - tgaTypeOfImage _ = ImageTypeMonochrome False - -instance TgaSaveable PixelRGB8 where - tgaPixelDepthOfImage _ = 24 - tgaTypeOfImage _ = ImageTypeTrueColor False - tgaDataOfImage = toByteString . imageData . pixelMap flipRgb - where - flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r - -instance TgaSaveable PixelRGBA8 where - tgaPixelDepthOfImage _ = 32 - tgaTypeOfImage _ = ImageTypeTrueColor False - tgaDataOfImage = toByteString . imageData . pixelMap flipRgba - where - flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a - --- | Helper function to directly write an image a tga on disk. -writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO () -writeTga path img = Lb.writeFile path $ encodeTga img - --- | Transform a compatible image to a raw bytestring --- representing a Targa file. -encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString -encodeTga img = encode file - where - file = TgaFile - { _tgaFileHeader = TgaHeader - { _tgaHdrIdLength = 0 - , _tgaHdrColorMapType = ColorMapWithoutTable - , _tgaHdrImageType = tgaTypeOfImage img - , _tgaHdrMapStart = 0 - , _tgaHdrMapLength = 0 - , _tgaHdrMapDepth = 0 - , _tgaHdrXOffset = 0 - , _tgaHdrYOffset = 0 - , _tgaHdrWidth = fromIntegral $ imageWidth img - , _tgaHdrHeight = fromIntegral $ imageHeight img - , _tgaHdrPixelDepth = tgaPixelDepthOfImage img - , _tgaHdrImageDescription = TgaImageDescription - { _tgaIdXOrigin = False - , _tgaIdYOrigin = False - , _tgaIdAttributeBits = 0 - } - } - , _tgaFileId = mempty - , _tgaPalette = mempty - , _tgaFileRest = tgaDataOfImage img - } - +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +-- | Module implementing function to read and write +-- Targa (*.tga) files. +module Codec.Picture.Tga( decodeTga + , TgaSaveable + , encodeTga + , writeTga + ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Control.Applicative( (<*>), pure, (<$>) ) +#endif + +import Control.Monad.ST( ST, runST ) +import Data.Bits( (.&.) + , (.|.) + , bit + , testBit + , setBit + , unsafeShiftL + , unsafeShiftR ) +import Data.Word( Word8, Word16 ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get + , getByteString + , getWord8 + , getWord16le + ) +import Data.Binary.Put( putWord8 + , putWord16le + , putByteString + ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as U +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.InternalHelper +import Codec.Picture.VectorByteConversion + +data TgaColorMapType + = ColorMapWithoutTable + | ColorMapWithTable + | ColorMapUnknown Word8 + +instance Binary TgaColorMapType where + get = do + v <- getWord8 + return $ case v of + 0 -> ColorMapWithoutTable + 1 -> ColorMapWithTable + n -> ColorMapUnknown n + + put v = case v of + ColorMapWithoutTable -> putWord8 0 + ColorMapWithTable -> putWord8 1 + (ColorMapUnknown vv) -> putWord8 vv + +data TgaImageType + = ImageTypeNoData Bool + | ImageTypeColorMapped Bool + | ImageTypeTrueColor Bool + | ImageTypeMonochrome Bool + +isRleEncoded :: TgaImageType -> Bool +isRleEncoded v = case v of + ImageTypeNoData yn -> yn + ImageTypeColorMapped yn -> yn + ImageTypeTrueColor yn -> yn + ImageTypeMonochrome yn -> yn + +imageTypeOfCode :: Monad m => Word8 -> m TgaImageType +imageTypeOfCode v = case v .&. 3 of + 0 -> return $ ImageTypeNoData isEncoded + 1 -> return $ ImageTypeColorMapped isEncoded + 2 -> return $ ImageTypeTrueColor isEncoded + 3 -> return $ ImageTypeMonochrome isEncoded + _ -> fail $ "Unknown TGA image type " ++ show v + where + isEncoded = testBit v 3 + +codeOfImageType :: TgaImageType -> Word8 +codeOfImageType v = case v of + ImageTypeNoData encoded -> setVal 0 encoded + ImageTypeColorMapped encoded -> setVal 1 encoded + ImageTypeTrueColor encoded -> setVal 2 encoded + ImageTypeMonochrome encoded -> setVal 3 encoded + where + setVal vv True = setBit vv 3 + setVal vv False = vv + +instance Binary TgaImageType where + get = getWord8 >>= imageTypeOfCode + put = putWord8 . codeOfImageType + +data TgaImageDescription = TgaImageDescription + { _tgaIdXOrigin :: Bool + , _tgaIdYOrigin :: Bool + , _tgaIdAttributeBits :: Word8 + } + +instance Binary TgaImageDescription where + put desc = putWord8 $ xOrig .|. yOrig .|. attr + where + xOrig | _tgaIdXOrigin desc = bit 4 + | otherwise = 0 + + yOrig | not $ _tgaIdYOrigin desc = bit 5 + | otherwise = 0 + + attr = _tgaIdAttributeBits desc .&. 0xF + + get = toDescr <$> getWord8 where + toDescr v = TgaImageDescription + { _tgaIdXOrigin = testBit v 4 + , _tgaIdYOrigin = not $ testBit v 5 + , _tgaIdAttributeBits = v .&. 0xF + } + +data TgaHeader = TgaHeader + { _tgaHdrIdLength :: {-# UNPACK #-} !Word8 + , _tgaHdrColorMapType :: !TgaColorMapType + , _tgaHdrImageType :: !TgaImageType + , _tgaHdrMapStart :: {-# UNPACK #-} !Word16 + , _tgaHdrMapLength :: {-# UNPACK #-} !Word16 + , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrXOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrYOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrWidth :: {-# UNPACK #-} !Word16 + , _tgaHdrHeight :: {-# UNPACK #-} !Word16 + , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription + } + +instance Binary TgaHeader where + get = TgaHeader + <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8 + <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get + where g16 = getWord16le + g8 = getWord8 + + put v = do + let p8 = putWord8 + p16 = putWord16le + p8 $ _tgaHdrIdLength v + put $ _tgaHdrColorMapType v + put $ _tgaHdrImageType v + + p16 $ _tgaHdrMapStart v + p16 $ _tgaHdrMapLength v + p8 $ _tgaHdrMapDepth v + p16 $ _tgaHdrXOffset v + p16 $ _tgaHdrYOffset v + p16 $ _tgaHdrWidth v + p16 $ _tgaHdrHeight v + p8 $ _tgaHdrPixelDepth v + put $ _tgaHdrImageDescription v + + +data TgaFile = TgaFile + { _tgaFileHeader :: !TgaHeader + , _tgaFileId :: !B.ByteString + , _tgaPalette :: !B.ByteString + , _tgaFileRest :: !B.ByteString + } + +getPalette :: TgaHeader -> Get B.ByteString +getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty +getPalette hdr = getByteString $ bytePerPixel * pixelCount + where + bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8 + pixelCount = fromIntegral $ _tgaHdrMapLength hdr + +instance Binary TgaFile where + get = do + hdr <- get + validateTga hdr + fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr + palette <- getPalette hdr + rest <- getRemainingBytes + + return TgaFile { + _tgaFileHeader = hdr + , _tgaFileId = fileId + , _tgaPalette = palette + , _tgaFileRest = rest + } + + put file = do + put $ _tgaFileHeader file + putByteString $ _tgaFileId file + putByteString $ _tgaPalette file + putByteString $ _tgaFileRest file + +data Depth8 = Depth8 +data Depth15 = Depth15 +data Depth24 = Depth24 +data Depth32 = Depth32 + +class (Pixel (Unpacked a)) => TGAPixel a where + type Unpacked a + packedByteSize :: a -> Int + tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a + +instance TGAPixel Depth8 where + type Unpacked Depth8 = Pixel8 + packedByteSize _ = 1 + tgaUnpack _ = U.unsafeIndex + +instance TGAPixel Depth15 where + type Unpacked Depth15 = PixelRGBA8 + packedByteSize _ = 2 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + v0 = U.unsafeIndex str ix + v1 = U.unsafeIndex str $ ix + 1 + r = (v1 .&. 0x7c) `unsafeShiftL` 1; + g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2); + b = (v0 .&. 0x1f) `unsafeShiftL` 3 + a = 255 -- v1 .&. 0x80 + +instance TGAPixel Depth24 where + type Unpacked Depth24 = PixelRGB8 + packedByteSize _ = 3 + tgaUnpack _ str ix = PixelRGB8 r g b + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + +instance TGAPixel Depth32 where + type Unpacked Depth32 = PixelRGBA8 + packedByteSize _ = 4 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + a = 255 - U.unsafeIndex str (ix + 3) + +prepareUnpacker :: TgaFile + -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx)) + -> Either String DynamicImage +prepareUnpacker file f = + let hdr = _tgaFileHeader file + flipper :: (Pixel px) => Image px -> Image px + flipper = flipImage $ _tgaHdrImageDescription hdr + in + case _tgaHdrPixelDepth hdr of + 8 -> pure . ImageY8 . flipper $ f Depth8 file + 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file + 24 -> pure . ImageRGB8 . flipper $ f Depth24 file + 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file + n -> fail $ "Invalid bit depth (" ++ show n ++ ")" + +applyPalette :: (Pixel px) + => (Image px -> DynamicImage) -> Image px + -> DynamicImage + -> Either String DynamicImage +applyPalette f palette (ImageY8 img) = + pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img +applyPalette _ _ _ = + fail "Bad colorspace for image" + +unparse :: TgaFile -> Either String DynamicImage +unparse file = + let hdr = _tgaFileHeader file + imageType = _tgaHdrImageType hdr + + unpacker :: forall tgapx. (TGAPixel tgapx) + => tgapx -> TgaFile -> Image (Unpacked tgapx) + unpacker | isRleEncoded imageType = unpackRLETga + | otherwise = unpackUncompressedTga + + decodedPalette = unparse file + { _tgaFileHeader = hdr + { _tgaHdrHeight = 1 + , _tgaHdrWidth = _tgaHdrMapLength hdr + , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr + , _tgaHdrImageType = ImageTypeTrueColor False + } + , _tgaFileRest = _tgaPalette file + } + in + case imageType of + ImageTypeNoData _ -> fail "No data detected in TGA file" + ImageTypeTrueColor _ -> + prepareUnpacker file unpacker + ImageTypeMonochrome _ -> + prepareUnpacker file unpacker + ImageTypeColorMapped _ -> + case decodedPalette of + Left str -> Left str + Right (ImageY8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageY8 img + Right (ImageRGB8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img + Right (ImageRGBA8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img + Right _ -> fail "Unknown pixel type" + +writeRun :: (Pixel px) + => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int + -> ST s Int +writeRun imgData localMaxi px = run + where + writeDelta = componentCount px + run writeIndex + | writeIndex >= localMaxi = return writeIndex + run writeIndex = do + unsafeWritePixel imgData writeIndex px + run $ writeIndex + writeDelta + +copyData :: forall tgapx s + . (TGAPixel tgapx) + => tgapx + -> M.STVector s (PixelBaseComponent (Unpacked tgapx)) + -> B.ByteString + -> Int -> Int + -> Int -> Int + -> ST s (Int, Int) +copyData tgapx imgData readData maxi maxRead = go + where + readDelta = packedByteSize tgapx + writeDelta = componentCount (undefined :: Unpacked tgapx) + + go writeIndex readIndex + | writeIndex >= maxi || + readIndex >= maxRead = return (writeIndex, readIndex) + go writeIndex readIndex = do + let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx + unsafeWritePixel imgData writeIndex px + go (writeIndex + writeDelta) (readIndex + readDelta) + +unpackUncompressedTga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackUncompressedTga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + _ <- copyData tga imgData readData maxi maxRead 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + +isRleChunk :: Word8 -> Bool +isRleChunk v = testBit v 7 + +runLength :: Word8 -> Int +runLength v = fromIntegral (v .&. 0x7F) + 1 + +unpackRLETga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackRLETga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + + go writeIndex readIndex + | writeIndex >= maxi = return () + | readIndex >= maxRead = return () + go writeIndex readIndex = do + let code = U.unsafeIndex readData readIndex + copyMax = min maxi $ writeIndex + runLength code * compCount + + if isRleChunk code then do + let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx + lastWriteIndex <- writeRun imgData copyMax px writeIndex + go lastWriteIndex $ readIndex + 1 + readDelta + + else do + (newWrite, newRead) <- + copyData tga imgData readData copyMax maxRead + writeIndex (readIndex + 1) + go newWrite newRead + + go 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + readDelta = packedByteSize tga + +flipImage :: (Pixel px) + => TgaImageDescription -> Image px -> Image px +flipImage desc img + | xFlip && yFlip = + generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h + | xFlip = + generateImage (\x y -> pixelAt img (wMax - x) y) w h + | yFlip = + generateImage (\x y -> pixelAt img x (hMax - y)) w h + | otherwise = img + where + xFlip = _tgaIdXOrigin desc + yFlip = _tgaIdYOrigin desc + w = imageWidth img + h = imageHeight img + + !wMax = w - 1 + !hMax = h - 1 + +validateTga :: (Monad m) => TgaHeader -> m () +validateTga hdr + | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative" + | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative" +validateTga _ = return () + +-- | Transform a raw tga image to an image, without modifying +-- the underlying pixel type. +-- +-- This function can output the following pixel types: +-- +-- * PixelY8 +-- +-- * PixelRGB8 +-- +-- * PixelRGBA8 +-- +decodeTga :: B.ByteString -> Either String DynamicImage +decodeTga byte = runGetStrict get byte >>= unparse + +-- | This typeclass determine if a pixel can be saved in the +-- TGA format. +class TgaSaveable a where + tgaDataOfImage :: Image a -> B.ByteString + tgaPixelDepthOfImage :: Image a -> Word8 + tgaTypeOfImage :: Image a -> TgaImageType + +instance TgaSaveable Pixel8 where + tgaDataOfImage = toByteString . imageData + tgaPixelDepthOfImage _ = 8 + tgaTypeOfImage _ = ImageTypeMonochrome False + +instance TgaSaveable PixelRGB8 where + tgaPixelDepthOfImage _ = 24 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgb + where + flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r + +instance TgaSaveable PixelRGBA8 where + tgaPixelDepthOfImage _ = 32 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgba + where + flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a + +-- | Helper function to directly write an image a tga on disk. +writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO () +writeTga path img = Lb.writeFile path $ encodeTga img + +-- | Transform a compatible image to a raw bytestring +-- representing a Targa file. +encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString +encodeTga img = encode file + where + file = TgaFile + { _tgaFileHeader = TgaHeader + { _tgaHdrIdLength = 0 + , _tgaHdrColorMapType = ColorMapWithoutTable + , _tgaHdrImageType = tgaTypeOfImage img + , _tgaHdrMapStart = 0 + , _tgaHdrMapLength = 0 + , _tgaHdrMapDepth = 0 + , _tgaHdrXOffset = 0 + , _tgaHdrYOffset = 0 + , _tgaHdrWidth = fromIntegral $ imageWidth img + , _tgaHdrHeight = fromIntegral $ imageHeight img + , _tgaHdrPixelDepth = tgaPixelDepthOfImage img + , _tgaHdrImageDescription = TgaImageDescription + { _tgaIdXOrigin = False + , _tgaIdYOrigin = False + , _tgaIdAttributeBits = 0 + } + } + , _tgaFileId = mempty + , _tgaPalette = mempty + , _tgaFileRest = tgaDataOfImage img + } + +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs --- a/src/Codec/Picture/Tiff.hs +++ b/src/Codec/Picture/Tiff.hs @@ -1,1350 +1,892 @@ -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} --- | 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 - - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>), pure ) -#endif - -import Control.Monad( when, replicateM, foldM_, unless ) -import Control.Monad.ST( ST, runST ) -import Control.Monad.Writer.Strict( execWriter, tell, Writer ) -import Data.Int( Int8 ) -import Data.Word( Word8, Word16, Word32 ) -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 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 ExtraSample - = ExtraSampleUnspecified -- ^ 0 - | ExtraSampleAssociatedAlpha -- ^ 1 - | ExtraSampleUnassociatedAlpha -- ^ 2 - -codeOfExtraSample :: ExtraSample -> Word16 -codeOfExtraSample ExtraSampleUnspecified = 0 -codeOfExtraSample ExtraSampleAssociatedAlpha = 1 -codeOfExtraSample ExtraSampleUnassociatedAlpha = 2 - -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 - , tiffExtraSample :: Maybe ExtraSample - } - -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 = - 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, stripSampleCount, offset, packedSize) = do - let (writeIdx, tempStride) = offsetStride comp idx 1 - _ <- uncompressAt compression str tempVec tempStride - writeIdx (offset, packedSize) - let typ :: M.MVector s a -> a - typ = const undefined - sampleSize = sizeOf (typ outVec) - mergeBackTempBuffer comp endianness tempVec (width * sampleCount) - idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec - - - fullStripSampleCount = rowPerStrip * width * sampleCount - startWriteOffset = V.generate stripCount (fullStripSampleCount *) - stripSampleCounts = V.map strip startWriteOffset - where - strip start = min fullStripSampleCount (width * height * sampleCount - start) - - sizes = V.zip4 startWriteOffset stripSampleCounts - (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 - - maybe (return ()) - (ifdShort TagExtraSample . codeOfExtraSample) - $ tiffExtraSample nfo - - let subSampling = tiffYCbCrSubsampling nfo - unless (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) - <*> pure Nothing - -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 } = do - img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) - case img of - ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i - ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i - ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a - in pure . ImageYA8 $ pixelMap negative i - ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a - in pure . ImageYA16 $ pixelMap negative i - _ -> fail "Unsupported color type used with colorspace MonochromeWhite0" - -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome - , tiffBitsPerSample = lst - , tiffSampleFormat = format } - | lst == V.singleton 2 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo - | lst == V.singleton 4 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ 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 (colorMap expand12to16) $ 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 = - let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 - img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 - in - pure . ImageY16 $ pixelMap toWord16 img - | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo - | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = - pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo - | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = - pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo - | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = - pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo - | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = - pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo - where - expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) - -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 (0x55 *)) $ gatherStrips Pack2 file nfo - | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ 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" - --- | Decode a tiff encoded image while preserving the underlying --- pixel type (except for Y32 which is truncated to 16 bits). --- --- This function can output the following pixel types: --- --- * PixelY8 --- --- * PixelY16 --- --- * PixelYA8 --- --- * PixelYA16 --- --- * PixelRGB8 --- --- * PixelRGB16 --- --- * PixelRGBA8 --- --- * PixelRGBA16 --- --- * 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 - - extraSampleCodeOfPixel :: px -> Maybe ExtraSample - extraSampleCodeOfPixel _ = Nothing - - subSamplingInfo :: px -> V.Vector Word32 - subSamplingInfo _ = V.empty - -instance TiffSaveable Pixel8 where - colorSpaceOfPixel _ = TiffMonochrome - -instance TiffSaveable Pixel16 where - colorSpaceOfPixel _ = TiffMonochrome - -instance TiffSaveable PixelYA8 where - colorSpaceOfPixel _ = TiffMonochrome - extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha - -instance TiffSaveable PixelYA16 where - colorSpaceOfPixel _ = TiffMonochrome - extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha - -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 - extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha - -instance TiffSaveable PixelRGBA16 where - colorSpaceOfPixel _ = TiffRGB - extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha - -instance TiffSaveable PixelYCbCr8 where - colorSpaceOfPixel _ = TiffYCbCr - subSamplingInfo _ = V.fromListN 2 [1, 1] - --- | Transform an image into a Tiff encoded bytestring, ready 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) - , tiffExtraSample = extraSampleCodeOfPixel (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 - +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +-- | 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 + , decodeTiffWithMetadata + , TiffSaveable + , encodeTiff + , writeTiff + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( mempty ) +#endif + +import Control.Monad( when, foldM_, unless, forM_ ) +import Control.Monad.ST( ST, runST ) +import Control.Monad.Writer.Strict( execWriter, tell, Writer ) +import Data.Int( Int8 ) +import Data.Word( Word8, Word16, Word32 ) +import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.Binary.Get( Get ) +import Data.Binary.Put( runPut ) + +import qualified Data.Vector as V +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 Lb +import qualified Data.ByteString.Unsafe as BU + +import Foreign.Storable( sizeOf ) + +import Codec.Picture.Metadata.Exif +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.InternalHelper +import Codec.Picture.BitWriter +import Codec.Picture.Types +import Codec.Picture.Gif.LZW +import Codec.Picture.Tiff.Types +import Codec.Picture.Tiff.Metadata +import Codec.Picture.VectorByteConversion( toByteString ) + +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 + , tiffExtraSample :: Maybe ExtraSample + , tiffPredictor :: Predictor + , tiffMetadatas :: Metadatas + } + +unLong :: String -> ExifData -> Get (V.Vector Word32) +unLong _ (ExifShorts v) = pure $ V.map fromIntegral v +unLong _ (ExifLongs v) = pure v +unLong errMessage _ = fail errMessage + +findIFD :: String -> ExifTag -> [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 = ExifShorts 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 -> ExifTag -> [ImageFileDirectory] -> Get Word32 +findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst + +findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32 +findIFDDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (x:_) -> pure $ ifdOffset x + +findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData +findIFDExt msg tag lst = do + val <- findIFD msg tag lst + case val of + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> + pure . ExifShorts . V.singleton $ fromIntegral ofs + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> + pure . ExifLongs . V.singleton $ fromIntegral ofs + ImageFileDirectory { ifdExtended = v } -> pure v + + +findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory] + -> Get [Word32] +findIFDExtDefaultData d tag lst = + case [v | v <- lst, ifdIdentifier v == tag] of + [] -> pure d + (ImageFileDirectory { ifdExtended = ExifNone }:_) -> 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" +-} +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 = + 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, stripSampleCount, offset, packedSize) = do + let (writeIdx, tempStride) = offsetStride comp idx 1 + _ <- uncompressAt compression str tempVec tempStride + writeIdx (offset, packedSize) + let typ :: M.MVector s a -> a + typ = const undefined + sampleSize = sizeOf (typ outVec) + mergeBackTempBuffer comp endianness tempVec (width * sampleCount) + idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec + + + fullStripSampleCount = rowPerStrip * width * sampleCount + startWriteOffset = V.generate stripCount (fullStripSampleCount *) + stripSampleCounts = V.map strip startWriteOffset + where + strip start = min fullStripSampleCount (width * height * sampleCount - start) + + sizes = V.zip4 startWriteOffset stripSampleCounts + (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) + + when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do + let f _ c1 c2 = c1 + c2 + forM_ [0 .. height - 1] $ \y -> + forM_ [1 .. width - 1] $ \x -> do + p <- readPixel mutableImage (x - 1) y + q <- readPixel mutableImage x y + writePixel mutableImage x y $ mixWith f p q + + unsafeFreezeImage mutableImage + +ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] () +ifdSingleLong tag = ifdMultiLong tag . V.singleton + +ifdSingleShort :: Endianness -> ExifTag -> Word16 + -> Writer [ImageFileDirectory] () +ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral + +ifdMultiLong :: ExifTag -> 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, ExifLongs v) + | otherwise = (V.head v, ExifNone) + +ifdMultiShort :: Endianness -> ExifTag -> 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, ExifShorts $ 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, ExifNone) + EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone) + + | otherwise = case endian of + EndianLittle -> (V.head v, ExifNone) + EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone) + +instance BinaryParam B.ByteString TiffInfo where + putP rawData nfo = putP rawData (tiffHeader nfo, list) where + endianness = hdrEndianness $ tiffHeader nfo + + ifdShort = ifdSingleShort endianness + ifdShorts = ifdMultiShort endianness + + list = 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 + + maybe (return ()) + (ifdShort TagExtraSample . codeOfExtraSample) + $ tiffExtraSample nfo + + let subSampling = tiffYCbCrSubsampling nfo + unless (V.null subSampling) $ + ifdShorts TagYCbCrSubsampling subSampling + + getP rawData = do + (hdr, cleaned) <- getP rawData + + 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) + <*> pure Nothing + <*> (dataDefault 1 TagPredictor + >>= predictorOfConstant) + <*> pure (extractTiffMetadata cleaned) + +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 } = do + img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) + case img of + ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i + ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i + ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a + in pure . ImageYA8 $ pixelMap negative i + ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a + in pure . ImageYA16 $ pixelMap negative i + _ -> fail "Unsupported color type used with colorspace MonochromeWhite0" + +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome + , tiffBitsPerSample = lst + , tiffSampleFormat = format } + | lst == V.singleton 2 && all (TiffSampleUint ==) format = + pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.singleton 4 && all (TiffSampleUint ==) format = + pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ 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 (colorMap expand12to16) $ 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 = + let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 + img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + in + pure . ImageY16 $ pixelMap toWord16 img + | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = + pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = + pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = + pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = + pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = + pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo + where + expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) + +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 (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = + pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ 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" + +-- | Decode a tiff encoded image while preserving the underlying +-- pixel type (except for Y32 which is truncated to 16 bits). +-- +-- This function can output the following pixel types: +-- +-- * PixelY8 +-- +-- * PixelY16 +-- +-- * PixelYA8 +-- +-- * PixelYA16 +-- +-- * PixelRGB8 +-- +-- * PixelRGB16 +-- +-- * PixelRGBA8 +-- +-- * PixelRGBA16 +-- +-- * PixelCMYK8 +-- +-- * PixelCMYK16 +-- +decodeTiff :: B.ByteString -> Either String DynamicImage +decodeTiff = fmap fst . decodeTiffWithMetadata + +-- | Like 'decodeTiff' but also provides some metdata present +-- in the Tiff file. +-- +-- The metadata extracted are the DpiX & DpiY information alongside +-- the EXIF informations. +decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTiffWithMetadata file = runGetStrict (getP file) file >>= go + where + go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo + + +-- | Class defining which pixel types can be serialized in a +-- Tiff file. +class (Pixel px) => TiffSaveable px where + colorSpaceOfPixel :: px -> TiffColorspace + + extraSampleCodeOfPixel :: px -> Maybe ExtraSample + extraSampleCodeOfPixel _ = Nothing + + subSamplingInfo :: px -> V.Vector Word32 + subSamplingInfo _ = V.empty + +instance TiffSaveable Pixel8 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable Pixel16 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable PixelYA8 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelYA16 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +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 + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelRGBA16 where + colorSpaceOfPixel _ = TiffRGB + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelYCbCr8 where + colorSpaceOfPixel _ = TiffYCbCr + subSamplingInfo _ = V.fromListN 2 [1, 1] + +-- | Transform an image into a Tiff encoded bytestring, ready 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) + , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px) + , tiffPredictor = PredictorNone -- not used when writing + , tiffMetadatas = mempty + } + +-- | 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 + +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Tiff/Metadata.hs b/src/Codec/Picture/Tiff/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tiff/Metadata.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE CPP #-} +module Codec.Picture.Tiff.Metadata( extractTiffMetadata ) where + +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( mempty ) +import Data.Foldable( foldMap ) +import Control.Applicative( (<$>) ) +#endif + +import Data.Foldable( find ) +import qualified Data.Foldable as F +import Data.Monoid( (<>) ) +import Codec.Picture.Metadata( Metadatas ) +import qualified Data.ByteString.Char8 as B +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Tiff.Types +import Codec.Picture.Metadata.Exif + +extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffStringMetadata = foldMap go where + strMeta k = Met.singleton k . B.unpack + exif ifd = + Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd + inserter acc (k, v) = Met.insert (Met.Exif k) v acc + + go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of + (TagUnknown _, _) -> exif ifd + (TagCopyright, ExifString v) -> strMeta Met.Copyright v + (TagArtist, ExifString v) -> strMeta Met.Author v + (TagDocumentName, ExifString v) -> strMeta Met.Title v + (TagSoftware, ExifString v) -> strMeta Met.Software v + (TagImageDescription, ExifString v) -> strMeta Met.Description v + (TagCompression, _) -> mempty + (TagImageWidth, _) -> mempty + (TagImageLength, _) -> mempty + (TagXResolution, _) -> mempty + (TagYResolution, _) -> mempty + (TagResolutionUnit, _) -> mempty + (TagRowPerStrip, _) -> mempty + (TagStripByteCounts, _) -> mempty + (TagStripOffsets, _) -> mempty + (TagBitsPerSample, _) -> mempty + (TagColorMap, _) -> mempty + (TagTileWidth, _) -> mempty + (TagTileLength, _) -> mempty + (TagTileOffset, _) -> mempty + (TagTileByteCount, _) -> mempty + (TagSamplesPerPixel, _) -> mempty + (TagYCbCrCoeff, _) -> mempty + (TagYCbCrSubsampling, _) -> mempty + (TagYCbCrPositioning, _) -> mempty + (TagJpegProc, _) -> mempty + (TagJPEGInterchangeFormat, _) -> mempty + (TagJPEGInterchangeFormatLength, _) -> mempty + (TagJPEGRestartInterval, _) -> mempty + (TagJPEGLosslessPredictors, _) -> mempty + (TagJPEGPointTransforms, _) -> mempty + (TagJPEGQTables, _) -> mempty + (TagJPEGDCTables, _) -> mempty + (TagJPEGACTables, _) -> mempty + (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst + _ -> mempty + +byTag :: ExifTag -> ImageFileDirectory -> Bool +byTag t ifd = ifdIdentifier ifd == t + +data TiffResolutionUnit + = ResolutionUnitUnknown + | ResolutionUnitInch + | ResolutionUnitCentimeter + +unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit +unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of + (TypeShort, 1) -> ResolutionUnitUnknown + (TypeShort, 2) -> ResolutionUnitInch + (TypeShort, 3) -> ResolutionUnitCentimeter + _ -> ResolutionUnitUnknown + +extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffDpiMetadata lst = go where + go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of + Nothing -> mempty + Just ResolutionUnitUnknown -> mempty + Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty + Just ResolutionUnitInch -> findDpis id mempty + + findDpis toDpi = + findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi + + findDpi k tag toDpi metas = case find (byTag tag) lst of + Nothing -> metas + Just ImageFileDirectory { ifdExtended = ExifRational num den } -> + Met.insert k (toDpi . fromIntegral $ num `div` den) metas + Just _ -> metas + +extractTiffMetadata :: [ImageFileDirectory] -> Metadatas +extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst + diff --git a/src/Codec/Picture/Tiff/Types.hs b/src/Codec/Picture/Tiff/Types.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tiff/Types.hs @@ -0,0 +1,461 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +module Codec.Picture.Tiff.Types + ( BinaryParam( .. ) + , Endianness( .. ) + , TiffHeader( .. ) + , TiffPlanarConfiguration( .. ) + , TiffCompression( .. ) + , IfdType( .. ) + , TiffColorspace( .. ) + , TiffSampleFormat( .. ) + , ImageFileDirectory( .. ) + , ExtraSample( .. ) + , Predictor( .. ) + + , planarConfgOfConstant + , constantToPlaneConfiguration + , unpackSampleFormat + , word16OfTag + , unpackPhotometricInterpretation + , packPhotometricInterpretation + , codeOfExtraSample + , unPackCompression + , packCompression + , predictorOfConstant + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +#endif + +import Control.Monad( when, replicateM, ) +import Data.Bits( (.&.), unsafeShiftR ) +import Data.Binary( Binary( .. ) ) +import Data.Binary.Get( Get + , getWord16le, getWord16be + , getWord32le, getWord32be + , bytesRead + , skip + , getByteString + ) +import Data.Binary.Put( Put + , putWord16le, putWord16be + , putWord32le, putWord32be + , putByteString + ) +import Data.Function( on ) +import Data.List( sortBy, mapAccumL ) +import qualified Data.Vector as V +import qualified Data.ByteString as B +import Data.Int( Int32 ) +import Data.Word( Word16, Word32 ) + +import Codec.Picture.Metadata.Exif +{-import Debug.Trace-} + +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 Int32 where + putP en v = putP en $ (fromIntegral v :: Word32) + getP en = fromIntegral <$> (getP en :: Get Word32) + +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 + deriving Show + +instance BinaryParam Endianness IfdType where + getP endianness = getP endianness >>= conv where + conv :: Word16 -> Get IfdType + conv v = case v of + 1 -> return TypeByte + 2 -> return TypeAscii + 3 -> return TypeShort + 4 -> return TypeLong + 5 -> return TypeRational + 6 -> return TypeSByte + 7 -> return TypeUndefined + 8 -> return TypeSignedShort + 9 -> return TypeSignedLong + 10 -> return TypeSignedRational + 11 -> return TypeFloat + 12 -> return TypeDouble + _ -> fail "Invalid TIF directory type" + + putP endianness = putP endianness . conv where + conv :: IfdType -> Word16 + conv v = case v of + TypeByte -> 1 + TypeAscii -> 2 + TypeShort -> 3 + TypeLong -> 4 + TypeRational -> 5 + TypeSByte -> 6 + TypeUndefined -> 7 + TypeSignedShort -> 8 + TypeSignedLong -> 9 + TypeSignedRational -> 10 + TypeFloat -> 11 + TypeDouble -> 12 + +instance BinaryParam Endianness ExifTag where + getP endianness = tagOfWord16 <$> getP endianness + putP endianness = putP endianness . word16OfTag + +data Predictor + = PredictorNone -- 1 + | PredictorHorizontalDifferencing -- 2 + deriving Eq + +predictorOfConstant :: Word32 -> Get Predictor +predictorOfConstant 1 = pure PredictorNone +predictorOfConstant 2 = pure PredictorHorizontalDifferencing +predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")" + +instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where + putP (endianness, _, _) = dump + where + dump ExifNone = pure () + dump (ExifLong _) = pure () + dump (ExifShort _) = pure () + dump (ExifIFD _) = pure () + dump (ExifString bstr) = putByteString bstr + dump (ExifUndefined bstr) = putByteString bstr + -- wrong if length == 2 + dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts + dump (ExifLongs longs) = V.mapM_ (putP endianness) longs + dump (ExifRational a b) = putP endianness a >> putP endianness b + dump (ExifSignedRational a b) = putP endianness a >> putP endianness b + + getP (endianness, maxi, ifd) = fetcher ifd + where + align ImageFileDirectory { ifdOffset = offset } act = do + readed <- bytesRead + let delta = fromIntegral offset - readed + if offset >= fromIntegral maxi || fromIntegral readed > offset then + pure ExifNone + else do + skip $ fromIntegral delta + act + + getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + getVec count = V.replicateM (fromIntegral count) + + fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd $ do + subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness + cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + {- + fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo + , ifdType = TypeLong + , ifdCount = 1 } = do + align ifd + subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness + cleaned <- fetchExtended endianness subIfds + pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] + -} + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 = + align ifd $ ExifUndefined <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } = + pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd) + [fromIntegral $ ofs .&. 0xFF000000 `unsafeShiftR` (3 * 8) + ,fromIntegral $ ofs .&. 0x00FF0000 `unsafeShiftR` (2 * 8) + ,fromIntegral $ ofs .&. 0x0000FF00 `unsafeShiftR` (1 * 8) + ,fromIntegral $ ofs .&. 0x000000FF + ] + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = + align ifd $ ExifString <$> getByteString (fromIntegral count) + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = + pure . ExifShorts $ 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 = TypeRational, ifdCount = 1 } = do + align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do + align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } = + pure . ExifShort . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = + align ifd $ ExifShorts <$> getVec count getE + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } = + pure . ExifLong . fromIntegral $ ifdOffset ifd + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = + align ifd $ ExifLongs <$> getVec count getE + fetcher _ = pure ExifNone + +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 + +fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory] +fetchExtended endian maxi = mapM $ \ifd -> do + v <- getP (endian, maxi, ifd) + pure $ ifd { ifdExtended = v } + +-- | 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 = ExifString b }) = + (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v }) + | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) + , ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v }) + | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) + , ifd { ifdOffset = ix }) + updater ix ifd = (ix, ifd) + +instance BinaryParam B.ByteString (TiffHeader, [ImageFileDirectory]) where + putP rawData (hdr, ifds) = do + put hdr + putByteString rawData + let endianness = hdrEndianness hdr + list = setupIfdOffsets (hdrOffset hdr) $ orderIfdByTag ifds + putP endianness list + mapM_ (\ifd -> putP (endianness, (0::Int), ifd) $ ifdExtended ifd) list + + getP raw = do + hdr <- get + readed <- bytesRead + skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed + let endian = hdrEndianness hdr + + ifd <- fmap (cleanImageFileDirectory endian) <$> getP endian + cleaned <- fetchExtended endian (B.length raw) ifd + return (hdr, cleaned) + +data TiffSampleFormat + = TiffSampleUint + | TiffSampleInt + | TiffSampleDouble + | TiffSampleUnknown + deriving Eq + +unpackSampleFormat :: Word32 -> Get TiffSampleFormat +unpackSampleFormat v = case v of + 1 -> pure TiffSampleUint + 2 -> pure TiffSampleInt + 3 -> pure TiffSampleDouble + 4 -> pure TiffSampleUnknown + vv -> fail $ "Undefined data format (" ++ show vv ++ ")" + +data ImageFileDirectory = ImageFileDirectory + { ifdIdentifier :: !ExifTag + , ifdType :: !IfdType + , ifdCount :: !Word32 + , ifdOffset :: !Word32 + , ifdExtended :: !ExifData + } + deriving Show + +instance BinaryParam Endianness ImageFileDirectory where + getP endianness = + ImageFileDirectory <$> getE <*> getE <*> getE <*> getE + <*> pure ExifNone + 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) + +data TiffColorspace + = TiffMonochromeWhite0 -- ^ 0 + | TiffMonochrome -- ^ 1 + | TiffRGB -- ^ 2 + | TiffPaleted -- ^ 3 + | TiffTransparencyMask -- ^ 4 + | TiffCMYK -- ^ 5 + | TiffYCbCr -- ^ 6 + | TiffCIELab -- ^ 8 + + +packPhotometricInterpretation :: TiffColorspace -> Word16 +packPhotometricInterpretation v = case v of + TiffMonochromeWhite0 -> 0 + TiffMonochrome -> 1 + TiffRGB -> 2 + TiffPaleted -> 3 + TiffTransparencyMask -> 4 + TiffCMYK -> 5 + TiffYCbCr -> 6 + TiffCIELab -> 8 + +unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace +unpackPhotometricInterpretation v = case v of + 0 -> pure TiffMonochromeWhite0 + 1 -> pure TiffMonochrome + 2 -> pure TiffRGB + 3 -> pure TiffPaleted + 4 -> pure TiffTransparencyMask + 5 -> pure TiffCMYK + 6 -> pure TiffYCbCr + 8 -> pure TiffCIELab + vv -> fail $ "Unrecognized color space " ++ show vv + +data ExtraSample + = ExtraSampleUnspecified -- ^ 0 + | ExtraSampleAssociatedAlpha -- ^ 1 + | ExtraSampleUnassociatedAlpha -- ^ 2 + +codeOfExtraSample :: ExtraSample -> Word16 +codeOfExtraSample v = case v of + ExtraSampleUnspecified -> 0 + ExtraSampleAssociatedAlpha -> 1 + ExtraSampleUnassociatedAlpha -> 2 + +unPackCompression :: Word32 -> Get TiffCompression +unPackCompression v = case v of + 0 -> pure CompressionNone + 1 -> pure CompressionNone + 2 -> pure CompressionModifiedRLE + 5 -> pure CompressionLZW + 6 -> pure CompressionJPEG + 32773 -> pure CompressionPackBit + vv -> fail $ "Unknown compression scheme " ++ show vv + +packCompression :: TiffCompression -> Word16 +packCompression v = case v of + CompressionNone -> 1 + CompressionModifiedRLE -> 2 + CompressionLZW -> 5 + CompressionJPEG -> 6 + CompressionPackBit -> 32773 + diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -228,7 +228,7 @@ | 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 + where plane = stride img padd comp padd = componentCount (undefined :: a) -- | For any image with an alpha component (transparency), @@ -253,14 +253,6 @@ {-# INLINE getTransparency #-} getTransparency (PixelRGBA8 _ _ _ a) = a --- | 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) - lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a {-# INLINE lineFold #-} lineFold initial count f = go 0 initial @@ -268,19 +260,18 @@ go n acc = f acc n >>= go (n + 1) stride :: (Storable (PixelBaseComponent a)) - => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) + => Image a -> 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 + padd firstComponent = runST $ do + let cell_count = w * h outArray <- M.new cell_count - let strideWrite write_idx _ | write_idx == cell_count = return () - strideWrite write_idx read_idx = do - lineMap (run - 1) $ \i -> - (outArray `M.unsafeWrite` (write_idx + i)) $ array `V.unsafeIndex` (read_idx + i) - strideWrite (write_idx + run) (read_idx + padd) + let go writeIndex _ | writeIndex >= cell_count = return () + go writeIndex readIndex = do + (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex + go (writeIndex + 1) $ readIndex + padd - strideWrite 0 firstComponent + go 0 firstComponent V.unsafeFreeze outArray instance NFData (Image a) where @@ -2132,7 +2123,7 @@ convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b) where tof :: Word8 -> Float - tof v = fromIntegral v + tof = fromIntegral clamp :: Float -> Word8 clamp = floor . max 0 . min 255 @@ -2147,7 +2138,7 @@ convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k where tof :: Word8 -> Float - tof v = fromIntegral v + tof = fromIntegral clamp :: Float -> Word8 clamp = floor . max 0 . min 255 @@ -2546,4 +2537,6 @@ !packedPtr = castForeignPtr ptr !converted = M.unsafeFromForeignPtr packedPtr s s2 + +{-# ANN module "HLint: ignore Reduce duplication" #-}