JuicyPixels 3.2.4 → 3.2.5
raw patch · 23 files changed
+4599/−3446 lines, 23 files
Files
- JuicyPixels.cabal +10/−4
- README.md +114/−0
- changelog +8/−1
- src/Codec/Picture.hs +39/−14
- src/Codec/Picture/BitWriter.hs +305/−303
- src/Codec/Picture/Bitmap.hs +59/−6
- src/Codec/Picture/Jpg.hs +64/−12
- src/Codec/Picture/Jpg/DefaultTable.hs +1/−1
- src/Codec/Picture/Jpg/FastDct.hs +218/−208
- src/Codec/Picture/Jpg/Metadata.hs +41/−0
- src/Codec/Picture/Jpg/Progressive.hs +325/−327
- src/Codec/Picture/Jpg/Types.hs +728/−628
- src/Codec/Picture/Metadata.hs +202/−0
- src/Codec/Picture/Metadata/Exif.hs +205/−0
- src/Codec/Picture/Png.hs +41/−27
- src/Codec/Picture/Png/Export.hs +71/−36
- src/Codec/Picture/Png/Metadata.hs +132/−0
- src/Codec/Picture/Png/Type.hs +63/−1
- src/Codec/Picture/Tga.hs +509/−508
- src/Codec/Picture/Tiff.hs +892/−1350
- src/Codec/Picture/Tiff/Metadata.hs +98/−0
- src/Codec/Picture/Tiff/Types.hs +461/−0
- src/Codec/Picture/Types.hs +13/−20
JuicyPixels.cabal view
@@ -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: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>@@ -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
+ README.md view
@@ -0,0 +1,114 @@+ + + +[](https://travis-ci.org/Twinside/Juicy.Pixels) +[](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/). +
changelog view
@@ -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.
src/Codec/Picture.hs view
@@ -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)
src/Codec/Picture/BitWriter.hs view
@@ -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" #-}+
src/Codec/Picture/Bitmap.hs view
@@ -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" #-}
src/Codec/Picture/Jpg.hs view
@@ -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
src/Codec/Picture/Jpg/DefaultTable.hs view
@@ -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 =
src/Codec/Picture/Jpg/FastDct.hs view
@@ -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" #-}+
+ src/Codec/Picture/Jpg/Metadata.hs view
@@ -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+ }+
src/Codec/Picture/Jpg/Progressive.hs view
@@ -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+
src/Codec/Picture/Jpg/Types.hs view
@@ -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
+ src/Codec/Picture/Metadata.hs view
@@ -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+
+ src/Codec/Picture/Metadata/Exif.hs view
@@ -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` ()
src/Codec/Picture/Png.hs view
@@ -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" #-}
src/Codec/Picture/Png/Export.hs view
@@ -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
+ src/Codec/Picture/Png/Metadata.hs view
@@ -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+
src/Codec/Picture/Png/Type.hs view
@@ -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]
src/Codec/Picture/Tga.hs view
@@ -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" #-}+
src/Codec/Picture/Tiff.hs view
@@ -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" #-}+
+ src/Codec/Picture/Tiff/Metadata.hs view
@@ -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+
+ src/Codec/Picture/Tiff/Types.hs view
@@ -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+
src/Codec/Picture/Types.hs view
@@ -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" #-}