diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.5.1 +Version: 3.2.5.2 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.5.1 + Tag: v3.2.5.2 Flag Mmap Description: Enable the file loading via mmap (memory map) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,8 +1,16 @@ Change log ========== -v3.2.5 May 2015 +V3.2.5.2 June 2015 +------------------ + + * Adding: Width & Height metdata to help querying image information + without decompressing the whole. + * Adding: Source format metadata. + +v3.2.5.1 May 2015 --------------- + * Fixing: utf-8 encoding of Jpg/Types causing problems with Haddock. v3.2.5 May 2015 diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs --- a/src/Codec/Picture.hs +++ b/src/Codec/Picture.hs @@ -136,7 +136,6 @@ #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) -import Data.Monoid( mempty ) #endif import Control.DeepSeq( NFData, deepseq ) @@ -163,6 +162,7 @@ import Codec.Picture.Gif( GifDelay , GifLooping( .. ) , decodeGif + , decodeGifWithMetadata , decodeGifImages , encodeGifImage , encodeGifImageWithPalette @@ -174,6 +174,7 @@ ) import Codec.Picture.HDR( decodeHDR + , decodeHDRWithMetadata , encodeHDR , writeHDR ) @@ -184,6 +185,7 @@ , writeTiff ) import Codec.Picture.Tga( TgaSaveable , decodeTga + , decodeTgaWithMetadata , encodeTga , writeTga ) @@ -275,14 +277,11 @@ [ ("Jpeg", decodeJpegWithMetadata) , ("PNG", decodePngWithMetadata) , ("Bitmap", decodeBitmapWithMetadata) - , ("GIF", noMeta decodeGif) - , ("HDR", noMeta decodeHDR) + , ("GIF", decodeGifWithMetadata) + , ("HDR", decodeHDRWithMetadata) , ("Tiff", decodeTiffWithMetadata) - , ("TGA", noMeta decodeTga) + , ("TGA", decodeTgaWithMetadata) ] - where - noMeta f = fmap (, mempty) . f - -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage) diff --git a/src/Codec/Picture/Bitmap.hs b/src/Codec/Picture/Bitmap.hs --- a/src/Codec/Picture/Bitmap.hs +++ b/src/Codec/Picture/Bitmap.hs @@ -312,7 +312,8 @@ return $ PixelRGB8 r g b metadataOfHeader :: BmpInfoHeader -> Metadatas -metadataOfHeader hdr = Met.insert Met.DpiY dpiY $ Met.singleton Met.DpiX dpiX +metadataOfHeader hdr = + Met.simpleMetadata Met.SourceBitmap (width hdr) (height hdr) dpiX dpiY where dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -1,825 +1,844 @@ -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} --- | Module implementing GIF decoding. -module Codec.Picture.Gif ( -- * Reading - decodeGif - , decodeGifImages - , getDelaysGifImages - - -- * Writing - , GifDelay - , GifLooping( .. ) - , encodeGifImage - , encodeGifImageWithPalette - , encodeGifImages - - , writeGifImage - , writeGifImageWithPalette - , writeGifImages - , greyPalette - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<*>), (<$>) ) -#endif - -import Control.Monad( replicateM, replicateM_, unless ) -import Control.Monad.ST( runST ) -import Control.Monad.Trans.Class( lift ) - -import Data.Bits( (.&.), (.|.) - , unsafeShiftR - , unsafeShiftL - , testBit, setBit ) -import Data.Word( Word8, Word16 ) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -import Data.Binary( Binary(..), encode ) -import Data.Binary.Get( Get - , getWord8 - , getWord16le - , getByteString - , bytesRead - , skip - ) - -import Data.Binary.Put( Put - , putWord8 - , putWord16le - , putByteString - ) - -import Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.Gif.LZW -import Codec.Picture.Gif.LZWEncoding -import Codec.Picture.BitWriter - --- | Delay to wait before showing the next Gif image. --- The delay is expressed in 100th of seconds. -type GifDelay = Int - --- | Help to control the behaviour of GIF animation looping. -data GifLooping = - -- | The animation will stop once the end is reached - LoopingNever - -- | The animation will restart once the end is reached - | LoopingForever - -- | The animation will repeat n times before stoping - | LoopingRepeat Word16 - -{- - ::= Header * Trailer - - ::= Logical Screen Descriptor [Global Color Table] - - ::= | - - - ::= [Graphic Control Extension] - - ::= | - Plain Text Extension - - ::= Image Descriptor [Local Color Table] Image Data - - ::= Application Extension | - Comment Extension - -} - --------------------------------------------------- ----- GifVersion --------------------------------------------------- -data GifVersion = GIF87a | GIF89a - -gif87aSignature, gif89aSignature :: B.ByteString -gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" -gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" - -instance Binary GifVersion where - put GIF87a = putByteString gif87aSignature - put GIF89a = putByteString gif89aSignature - - get = do - sig <- getByteString (B.length gif87aSignature) - case (sig == gif87aSignature, sig == gif89aSignature) of - (True, _) -> pure GIF87a - (_ , True) -> pure GIF89a - _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) - - --------------------------------------------------- ----- LogicalScreenDescriptor --------------------------------------------------- --- | Section 18 of spec-gif89a -data LogicalScreenDescriptor = LogicalScreenDescriptor - { -- | Stored on 16 bits - screenWidth :: !Word16 - -- | Stored on 16 bits - , screenHeight :: !Word16 - -- | Stored on 8 bits - , backgroundIndex :: !Word8 - - -- | Stored on 1 bit - , hasGlobalMap :: !Bool - -- | Stored on 3 bits - , colorResolution :: !Word8 - -- | Stored on 1 bit - , isColorTableSorted :: !Bool - -- | Stored on 3 bits - , colorTableSize :: !Word8 - } - -instance Binary LogicalScreenDescriptor where - put v = do - putWord16le $ screenWidth v - putWord16le $ screenHeight v - let globalMapField - | hasGlobalMap v = 0x80 - | otherwise = 0 - - colorTableSortedField - | isColorTableSorted v = 0x08 - | otherwise = 0 - - tableSizeField = (colorTableSize v - 1) .&. 7 - - colorResolutionField = - ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 - - packedField = globalMapField - .|. colorTableSortedField - .|. tableSizeField - .|. colorResolutionField - - putWord8 packedField - putWord8 0 -- aspect ratio - putWord8 $ backgroundIndex v - - get = do - w <- getWord16le - h <- getWord16le - packedField <- getWord8 - backgroundColorIndex <- getWord8 - _aspectRatio <- getWord8 - return LogicalScreenDescriptor - { screenWidth = w - , screenHeight = h - , hasGlobalMap = packedField `testBit` 7 - , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 - , isColorTableSorted = packedField `testBit` 3 - , colorTableSize = (packedField .&. 0x7) + 1 - , backgroundIndex = backgroundColorIndex - } - - --------------------------------------------------- ----- ImageDescriptor --------------------------------------------------- --- | Section 20 of spec-gif89a -data ImageDescriptor = ImageDescriptor - { gDescPixelsFromLeft :: !Word16 - , gDescPixelsFromTop :: !Word16 - , gDescImageWidth :: !Word16 - , gDescImageHeight :: !Word16 - , gDescHasLocalMap :: !Bool - , gDescIsInterlaced :: !Bool - , gDescIsImgDescriptorSorted :: !Bool - , gDescLocalColorTableSize :: !Word8 - } - -imageSeparator, extensionIntroducer, gifTrailer :: Word8 -imageSeparator = 0x2C -extensionIntroducer = 0x21 -gifTrailer = 0x3B - -graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 -plainTextLabel = 0x01 -graphicControlLabel = 0xF9 -commentLabel = 0xFE -applicationLabel = 0xFF - - -parseDataBlocks :: Get B.ByteString -parseDataBlocks = B.concat <$> (getWord8 >>= aux) - where aux 0 = pure [] - aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) - -putDataBlocks :: B.ByteString -> Put -putDataBlocks wholeString = putSlices wholeString >> putWord8 0 - where putSlices str | B.length str == 0 = pure () - | B.length str > 0xFF = - let (before, after) = B.splitAt 0xFF str in - putWord8 0xFF >> putByteString before >> putSlices after - putSlices str = - putWord8 (fromIntegral $ B.length str) >> putByteString str - -data DisposalMethod - = DisposalAny - | DisposalDoNot - | DisposalRestoreBackground - | DisposalRestorePrevious - | DisposalUnknown Word8 - -disposalMethodOfCode :: Word8 -> DisposalMethod -disposalMethodOfCode v = case v of - 0 -> DisposalAny - 1 -> DisposalDoNot - 2 -> DisposalRestoreBackground - 3 -> DisposalRestorePrevious - n -> DisposalUnknown n - -codeOfDisposalMethod :: DisposalMethod -> Word8 -codeOfDisposalMethod v = case v of - DisposalAny -> 0 - DisposalDoNot -> 1 - DisposalRestoreBackground -> 2 - DisposalRestorePrevious -> 3 - DisposalUnknown n -> n - -data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits - , gceUserInputFlag :: !Bool - , gceTransparentFlag :: !Bool - , gceDelay :: !Word16 - , gceTransparentColorIndex :: !Word8 - } - -instance Binary GraphicControlExtension where - put v = do - putWord8 extensionIntroducer - putWord8 graphicControlLabel - putWord8 0x4 -- size - let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v - disposalField = - (disposalCode .&. 0x7) `unsafeShiftL` 2 - - userInputField - | gceUserInputFlag v = 0 `setBit` 1 - | otherwise = 0 - - transparentField - | gceTransparentFlag v = 0 `setBit` 0 - | otherwise = 0 - - packedFields = disposalField - .|. userInputField - .|. transparentField - - putWord8 packedFields - putWord16le $ gceDelay v - putWord8 $ gceTransparentColorIndex v - putWord8 0 -- blockTerminator - - get = do - -- due to missing lookahead - {-_extensionLabel <- getWord8-} - _size <- getWord8 - packedFields <- getWord8 - delay <- getWord16le - idx <- getWord8 - _blockTerminator <- getWord8 - return GraphicControlExtension - { gceDisposalMethod = - disposalMethodOfCode $ - (packedFields `unsafeShiftR` 2) .&. 0x07 - , gceUserInputFlag = packedFields `testBit` 1 - , gceTransparentFlag = packedFields `testBit` 0 - , gceDelay = delay - , gceTransparentColorIndex = idx - } - -data GifImage = GifImage - { imgDescriptor :: !ImageDescriptor - , imgLocalPalette :: !(Maybe Palette) - , imgLzwRootSize :: !Word8 - , imgData :: B.ByteString - } - -instance Binary GifImage where - put img = do - let descriptor = imgDescriptor img - put descriptor - case ( imgLocalPalette img - , gDescHasLocalMap $ imgDescriptor img) of - (Nothing, _) -> return () - (Just _, False) -> return () - (Just p, True) -> - putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p - putWord8 $ imgLzwRootSize img - putDataBlocks $ imgData img - - get = do - desc <- get - let hasLocalColorTable = gDescHasLocalMap desc - palette <- if hasLocalColorTable - then Just <$> getPalette (gDescLocalColorTableSize desc) - else pure Nothing - - GifImage desc palette <$> getWord8 <*> parseDataBlocks - -data Block = BlockImage GifImage - | BlockGraphicControl GraphicControlExtension - -skipSubDataBlocks :: Get () -skipSubDataBlocks = do - s <- fromIntegral <$> getWord8 - unless (s == 0) $ - skip s >> skipSubDataBlocks - -parseGifBlocks :: Get [Block] -parseGifBlocks = getWord8 >>= blockParse - where - blockParse v - | v == gifTrailer = pure [] - | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks - | v == extensionIntroducer = getWord8 >>= extensionParse - - blockParse v = do - readPosition <- bytesRead - fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) - - extensionParse code - | code == graphicControlLabel = - (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks - | code == commentLabel = skipSubDataBlocks >> parseGifBlocks - | code `elem` [plainTextLabel, applicationLabel] = - fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks - | otherwise = parseDataBlocks >> parseGifBlocks - - -instance Binary ImageDescriptor where - put v = do - putWord8 imageSeparator - putWord16le $ gDescPixelsFromLeft v - putWord16le $ gDescPixelsFromTop v - putWord16le $ gDescImageWidth v - putWord16le $ gDescImageHeight v - let localMapField - | gDescHasLocalMap v = 0 `setBit` 7 - | otherwise = 0 - - isInterlacedField - | gDescIsInterlaced v = 0 `setBit` 6 - | otherwise = 0 - - isImageDescriptorSorted - | gDescIsImgDescriptorSorted v = 0 `setBit` 5 - | otherwise = 0 - - localSize = gDescLocalColorTableSize v - tableSizeField - | localSize > 0 = (localSize - 1) .&. 0x7 - | otherwise = 0 - - packedFields = localMapField - .|. isInterlacedField - .|. isImageDescriptorSorted - .|. tableSizeField - putWord8 packedFields - - get = do - -- due to missing lookahead - {-_imageSeparator <- getWord8-} - imgLeftPos <- getWord16le - imgTopPos <- getWord16le - imgWidth <- getWord16le - imgHeight <- getWord16le - packedFields <- getWord8 - let tableSize = packedFields .&. 0x7 - return ImageDescriptor - { gDescPixelsFromLeft = imgLeftPos - , gDescPixelsFromTop = imgTopPos - , gDescImageWidth = imgWidth - , gDescImageHeight = imgHeight - , gDescHasLocalMap = packedFields `testBit` 7 - , gDescIsInterlaced = packedFields `testBit` 6 - , gDescIsImgDescriptorSorted = packedFields `testBit` 5 - , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 - } - - --------------------------------------------------- ----- Palette --------------------------------------------------- -getPalette :: Word8 -> Get Palette -getPalette bitDepth = - Image size 1 . V.fromList <$> replicateM (size * 3) get - where size = 2 ^ (fromIntegral bitDepth :: Int) - -putPalette :: Int -> Palette -> Put -putPalette size pal = do - V.mapM_ putWord8 (imageData pal) - replicateM_ missingColorComponent (putWord8 0) - where elemCount = 2 ^ size - missingColorComponent = (elemCount - imageWidth pal) * 3 - --------------------------------------------------- ----- GifImage --------------------------------------------------- -data GifHeader = GifHeader - { gifVersion :: GifVersion - , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette - } - -instance Binary GifHeader where - put v = do - put $ gifVersion v - let descr = gifScreenDescriptor v - put descr - putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v - - get = do - version <- get - screenDesc <- get - - palette <- - if hasGlobalMap screenDesc then - getPalette $ colorTableSize screenDesc - else - return greyPalette - - return GifHeader - { gifVersion = version - , gifScreenDescriptor = screenDesc - , gifGlobalMap = palette - } - -data GifFile = GifFile - { gifHeader :: !GifHeader - , gifImages :: [(Maybe GraphicControlExtension, GifImage)] - , gifLoopingBehaviour :: GifLooping - } - -putLooping :: GifLooping -> Put -putLooping LoopingNever = return () -putLooping LoopingForever = putLooping $ LoopingRepeat 0 -putLooping (LoopingRepeat count) = do - putWord8 extensionIntroducer - putWord8 applicationLabel - putWord8 11 -- the size - putByteString $ BC.pack "NETSCAPE2.0" - putWord8 3 -- size of sub block - putWord8 1 - putWord16le count - putWord8 0 - -associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] -associateDescr [] = [] -associateDescr [BlockGraphicControl _] = [] -associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = - associateDescr rest -associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs -associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = - (Just ctrl, img) : associateDescr xs - -instance Binary GifFile where - put v = do - put $ gifHeader v - let putter (Nothing, i) = put i - putter (Just a, i) = put a >> put i - putLooping $ gifLoopingBehaviour v - mapM_ putter $ gifImages v - put gifTrailer - - get = do - hdr <- get - blocks <- parseGifBlocks - return GifFile { gifHeader = hdr - , gifImages = associateDescr blocks - , gifLoopingBehaviour = LoopingNever - } - -substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 -substituteColors palette = pixelMap swaper - where swaper n = pixelAt palette (fromIntegral n) 0 - -substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 -substituteColorsWithTransparency transparent palette = pixelMap swaper where - swaper n | ix == transparent = PixelRGBA8 0 0 0 0 - | otherwise = promotePixel $ pixelAt palette ix 0 - where ix = fromIntegral n - - -decodeImage :: GifImage -> Image Pixel8 -decodeImage img = runST $ runBoolReader $ do - outputVector <- lift . M.new $ width * height - decodeLzw (imgData img) 12 lzwRoot outputVector - frozenData <- lift $ V.unsafeFreeze outputVector - return . deinterlaceGif $ Image - { imageWidth = width - , imageHeight = height - , imageData = frozenData - } - where lzwRoot = fromIntegral $ imgLzwRootSize img - width = fromIntegral $ gDescImageWidth descriptor - height = fromIntegral $ gDescImageHeight descriptor - isInterlaced = gDescIsInterlaced descriptor - descriptor = imgDescriptor img - - deinterlaceGif | not isInterlaced = id - | otherwise = deinterlaceGifImage - -deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 -deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h - where lineIndices = gifInterlacingIndices h - generator x y = pixelAt img x y' - where y' = lineIndices V.! y - -gifInterlacingIndices :: Int -> V.Vector Int -gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices - where indices = flip zip [0..] $ - concat [ [0, 8 .. height - 1] - , [4, 4 + 8 .. height - 1] - , [2, 2 + 4 .. height - 1] - , [1, 1 + 2 .. height - 1] - ] - -paletteOf :: (ColorConvertible PixelRGB8 px) - => Image px -> GifImage -> Image px -paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p - -getFrameDelays :: GifFile -> [GifDelay] -getFrameDelays GifFile { gifImages = [] } = [] -getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs - where extractDelay (ext, _) = - case ext of - Nothing -> 0 - Just e -> fromIntegral $ gceDelay e - -transparentColorOf :: Maybe GraphicControlExtension -> Int -transparentColorOf Nothing = 300 -transparentColorOf (Just ext) - | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext - | otherwise = 300 - -hasTransparency :: Maybe GraphicControlExtension -> Bool -hasTransparency Nothing = False -hasTransparency (Just control) = gceTransparentFlag control - -decodeAllGifImages :: GifFile -> [DynamicImage] -decodeAllGifImages GifFile { gifImages = [] } = [] -decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor } - , gifImages = (firstControl, firstImage) : rest } - | not (hasTransparency firstControl) = - let backImage = - generateImage (\_ _ -> backgroundColor) globalWidth globalHeight - thisPalette = paletteOf palette firstImage - initState = - (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage) - scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage - in - [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest] - - | otherwise = - let backImage :: Image PixelRGBA8 - backImage = - generateImage (\_ _ -> transparentBackground) globalWidth globalHeight - - thisPalette :: Image PixelRGBA8 - thisPalette = paletteOf (promoteImage palette) firstImage - - transparentCode = transparentColorOf firstControl - decoded = - substituteColorsWithTransparency transparentCode thisPalette $ - decodeImage firstImage - - initState = (thisPalette, firstControl, decoded) - scanner = - gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in - [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] - - where - globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor - - transparentBackground = PixelRGBA8 r g b 0 - where PixelRGB8 r g b = backgroundColor - - backgroundColor - | hasGlobalMap wholeDescriptor = - pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 - | otherwise = PixelRGB8 0 0 0 - -gifAnimationApplyer :: forall px. - (Pixel px, ColorConvertible PixelRGB8 px) - => (Int, Int) -> Image px -> Image px - -> (Image px, Maybe GraphicControlExtension, Image px) - -> (Maybe GraphicControlExtension, GifImage) - -> (Image px, Maybe GraphicControlExtension, Image px) -gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage - (_, prevControl, img1) - (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (thisPalette, controlExt, thisImage) - where - thisPalette :: Image px - thisPalette = paletteOf globalPalette img2 - - thisImage = generateImage pixeler globalWidth globalHeight - localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor - - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor - - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight - - decoded :: Image Pixel8 - decoded = decodeImage img2 - - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 - - oldImage = case gceDisposalMethod <$> prevControl of - Nothing -> img1 - Just DisposalAny -> img1 - Just DisposalDoNot -> img1 - Just DisposalRestoreBackground -> backgroundImage - Just DisposalRestorePrevious -> img1 - Just (DisposalUnknown _) -> img1 - - pixeler x y - | isPixelInLocalImage x y && code /= transparent = val where - code = fromIntegral $ pixelAt decoded (x - left) (y - top) - val = pixelAt thisPalette (fromIntegral code) 0 - pixeler x y = pixelAt oldImage x y - -decodeFirstGifImage :: GifFile -> Either String DynamicImage -decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = - case decodeAllGifImages img { gifImages = [firstImage] } of - [] -> Left "No image after decoding" - (i:_) -> Right i -decodeFirstGifImage _ = Left "No image in gif file" - --- | Transform a raw gif image to an image, witout --- modifying the pixels. --- This function can output the following pixel types : --- --- * PixelRGB8 --- --- * PixelRGBA8 --- -decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = decode img >>= decodeFirstGifImage - --- | Transform a raw gif to a list of images, representing --- all the images of an animation. -decodeGifImages :: B.ByteString -> Either String [DynamicImage] -decodeGifImages img = decodeAllGifImages <$> decode img - --- | Extract a list of frame delays from a raw gif. -getDelaysGifImages :: B.ByteString -> Either String [GifDelay] -getDelaysGifImages img = getFrameDelays <$> decode img - --- | Default palette to produce greyscale images. -greyPalette :: Palette -greyPalette = generateImage toGrey 256 1 - where toGrey x _ = PixelRGB8 ix ix ix - where ix = fromIntegral x - -checkGifImageSizes :: [(a, b, Image px)] -> Bool -checkGifImageSizes [] = False -checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest - where width = imageWidth img - height = imageHeight img - - checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = - w == width && h == height - -checkPaletteValidity :: [(Palette, a, b)] -> Bool -checkPaletteValidity [] = False -checkPaletteValidity lst = - and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst - , let w = imageWidth p - h = imageHeight p ] - -areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool -areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img - where paletteElemCount = imageWidth palette - isTooBig v = fromIntegral v >= paletteElemCount - -computeMinimumLzwKeySize :: Palette -> Int -computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 - where go k | 2 ^ k >= itemCount = k - | otherwise = go $ k + 1 - --- | Encode a gif animation to a bytestring. --- --- * Every image must have the same size --- --- * Every palette must have between one and 256 colors. --- -encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] - -> Either String L.ByteString -encodeGifImages _ [] = Left "No image in list" -encodeGifImages _ imageList - | not $ checkGifImageSizes imageList = Left "Gif images have different size" - | not $ checkPaletteValidity imageList = - Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] - | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" -encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile - where - allFile = GifFile - { gifHeader = GifHeader - { gifVersion = GIF89a - , gifScreenDescriptor = logicalScreen - , gifGlobalMap = firstPalette - } - , gifImages = toSerialize - , gifLoopingBehaviour = looping - } - - logicalScreen = LogicalScreenDescriptor - { screenWidth = fromIntegral $ imageWidth firstImage - , screenHeight = fromIntegral $ imageHeight firstImage - , backgroundIndex = 0 - , hasGlobalMap = True - , colorResolution = 8 - , isColorTableSorted = False - , colorTableSize = 8 - } - - paletteEqual p = imageData firstPalette == imageData p - - controlExtension 0 = Nothing - controlExtension delay = Just GraphicControlExtension - { gceDisposalMethod = DisposalAny - , gceUserInputFlag = False - , gceTransparentFlag = False - , gceDelay = fromIntegral delay - , gceTransparentColorIndex = 0 - } - - toSerialize = [(controlExtension delay, GifImage - { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img - , imgLocalPalette = Just palette - , imgLzwRootSize = fromIntegral lzwKeySize - , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img - }) | (palette, delay, img) <- imageList - , let lzwKeySize = computeMinimumLzwKeySize palette - ] - - imageDescriptor paletteSize palEqual img = ImageDescriptor - { gDescPixelsFromLeft = 0 - , gDescPixelsFromTop = 0 - , gDescImageWidth = fromIntegral $ imageWidth img - , gDescImageHeight = fromIntegral $ imageHeight img - , gDescHasLocalMap = paletteSize > 0 && not palEqual - , gDescIsInterlaced = False - , gDescIsImgDescriptorSorted = False - , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize - } - --- | Encode a greyscale image to a bytestring. -encodeGifImage :: Image Pixel8 -> L.ByteString -encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of - Left err -> error $ "Impossible:" ++ err - Right v -> v - --- | Encode an image with a given palette. --- Can return errors if the palette is ill-formed. --- --- * A palette must have between 1 and 256 colors --- -encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString -encodeGifImageWithPalette img palette = - encodeGifImages LoopingNever [(palette, 0, img)] - --- | Write a greyscale in a gif file on the disk. -writeGifImage :: FilePath -> Image Pixel8 -> IO () -writeGifImage file = L.writeFile file . encodeGifImage - --- | Write a list of images as a gif animation in a file. --- --- * Every image must have the same size --- --- * Every palette must have between one and 256 colors. --- -writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] - -> Either String (IO ()) -writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst - --- | Write a gif image with a palette to a file. --- --- * A palette must have between 1 and 256 colors --- -writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette - -> Either String (IO ()) -writeGifImageWithPalette file img palette = - L.writeFile file <$> encodeGifImageWithPalette img palette - +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE CPP #-} +-- | Module implementing GIF decoding. +module Codec.Picture.Gif ( -- * Reading + decodeGif + , decodeGifWithMetadata + , decodeGifImages + , getDelaysGifImages + + -- * Writing + , GifDelay + , GifLooping( .. ) + , encodeGifImage + , encodeGifImageWithPalette + , encodeGifImages + + , writeGifImage + , writeGifImageWithPalette + , writeGifImages + , greyPalette + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +import Control.Monad( replicateM, replicateM_, unless ) +import Control.Monad.ST( runST ) +import Control.Monad.Trans.Class( lift ) + +import Data.Bits( (.&.), (.|.) + , unsafeShiftR + , unsafeShiftL + , testBit, setBit ) +import Data.Word( Word8, Word16 ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy as L +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +import Data.Binary( Binary(..), encode ) +import Data.Binary.Get( Get + , getWord8 + , getWord16le + , getByteString + , bytesRead + , skip + ) + +import Data.Binary.Put( Put + , putWord8 + , putWord16le + , putByteString + ) + +import Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceGif ) + , basicMetadata ) +import Codec.Picture.Gif.LZW +import Codec.Picture.Gif.LZWEncoding +import Codec.Picture.BitWriter + +-- | Delay to wait before showing the next Gif image. +-- The delay is expressed in 100th of seconds. +type GifDelay = Int + +-- | Help to control the behaviour of GIF animation looping. +data GifLooping = + -- | The animation will stop once the end is reached + LoopingNever + -- | The animation will restart once the end is reached + | LoopingForever + -- | The animation will repeat n times before stoping + | LoopingRepeat Word16 + +{- + ::= Header * Trailer + + ::= Logical Screen Descriptor [Global Color Table] + + ::= | + + + ::= [Graphic Control Extension] + + ::= | + Plain Text Extension + + ::= Image Descriptor [Local Color Table] Image Data + + ::= Application Extension | + Comment Extension + -} + +-------------------------------------------------- +---- GifVersion +-------------------------------------------------- +data GifVersion = GIF87a | GIF89a + +gif87aSignature, gif89aSignature :: B.ByteString +gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" +gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" + +instance Binary GifVersion where + put GIF87a = putByteString gif87aSignature + put GIF89a = putByteString gif89aSignature + + get = do + sig <- getByteString (B.length gif87aSignature) + case (sig == gif87aSignature, sig == gif89aSignature) of + (True, _) -> pure GIF87a + (_ , True) -> pure GIF89a + _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) + + +-------------------------------------------------- +---- LogicalScreenDescriptor +-------------------------------------------------- +-- | Section 18 of spec-gif89a +data LogicalScreenDescriptor = LogicalScreenDescriptor + { -- | Stored on 16 bits + screenWidth :: !Word16 + -- | Stored on 16 bits + , screenHeight :: !Word16 + -- | Stored on 8 bits + , backgroundIndex :: !Word8 + + -- | Stored on 1 bit + , hasGlobalMap :: !Bool + -- | Stored on 3 bits + , colorResolution :: !Word8 + -- | Stored on 1 bit + , isColorTableSorted :: !Bool + -- | Stored on 3 bits + , colorTableSize :: !Word8 + } + +instance Binary LogicalScreenDescriptor where + put v = do + putWord16le $ screenWidth v + putWord16le $ screenHeight v + let globalMapField + | hasGlobalMap v = 0x80 + | otherwise = 0 + + colorTableSortedField + | isColorTableSorted v = 0x08 + | otherwise = 0 + + tableSizeField = (colorTableSize v - 1) .&. 7 + + colorResolutionField = + ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 + + packedField = globalMapField + .|. colorTableSortedField + .|. tableSizeField + .|. colorResolutionField + + putWord8 packedField + putWord8 0 -- aspect ratio + putWord8 $ backgroundIndex v + + get = do + w <- getWord16le + h <- getWord16le + packedField <- getWord8 + backgroundColorIndex <- getWord8 + _aspectRatio <- getWord8 + return LogicalScreenDescriptor + { screenWidth = w + , screenHeight = h + , hasGlobalMap = packedField `testBit` 7 + , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 + , isColorTableSorted = packedField `testBit` 3 + , colorTableSize = (packedField .&. 0x7) + 1 + , backgroundIndex = backgroundColorIndex + } + + +-------------------------------------------------- +---- ImageDescriptor +-------------------------------------------------- +-- | Section 20 of spec-gif89a +data ImageDescriptor = ImageDescriptor + { gDescPixelsFromLeft :: !Word16 + , gDescPixelsFromTop :: !Word16 + , gDescImageWidth :: !Word16 + , gDescImageHeight :: !Word16 + , gDescHasLocalMap :: !Bool + , gDescIsInterlaced :: !Bool + , gDescIsImgDescriptorSorted :: !Bool + , gDescLocalColorTableSize :: !Word8 + } + +imageSeparator, extensionIntroducer, gifTrailer :: Word8 +imageSeparator = 0x2C +extensionIntroducer = 0x21 +gifTrailer = 0x3B + +graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 +plainTextLabel = 0x01 +graphicControlLabel = 0xF9 +commentLabel = 0xFE +applicationLabel = 0xFF + + +parseDataBlocks :: Get B.ByteString +parseDataBlocks = B.concat <$> (getWord8 >>= aux) + where aux 0 = pure [] + aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) + +putDataBlocks :: B.ByteString -> Put +putDataBlocks wholeString = putSlices wholeString >> putWord8 0 + where putSlices str | B.length str == 0 = pure () + | B.length str > 0xFF = + let (before, after) = B.splitAt 0xFF str in + putWord8 0xFF >> putByteString before >> putSlices after + putSlices str = + putWord8 (fromIntegral $ B.length str) >> putByteString str + +data DisposalMethod + = DisposalAny + | DisposalDoNot + | DisposalRestoreBackground + | DisposalRestorePrevious + | DisposalUnknown Word8 + +disposalMethodOfCode :: Word8 -> DisposalMethod +disposalMethodOfCode v = case v of + 0 -> DisposalAny + 1 -> DisposalDoNot + 2 -> DisposalRestoreBackground + 3 -> DisposalRestorePrevious + n -> DisposalUnknown n + +codeOfDisposalMethod :: DisposalMethod -> Word8 +codeOfDisposalMethod v = case v of + DisposalAny -> 0 + DisposalDoNot -> 1 + DisposalRestoreBackground -> 2 + DisposalRestorePrevious -> 3 + DisposalUnknown n -> n + +data GraphicControlExtension = GraphicControlExtension + { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits + , gceUserInputFlag :: !Bool + , gceTransparentFlag :: !Bool + , gceDelay :: !Word16 + , gceTransparentColorIndex :: !Word8 + } + +instance Binary GraphicControlExtension where + put v = do + putWord8 extensionIntroducer + putWord8 graphicControlLabel + putWord8 0x4 -- size + let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v + disposalField = + (disposalCode .&. 0x7) `unsafeShiftL` 2 + + userInputField + | gceUserInputFlag v = 0 `setBit` 1 + | otherwise = 0 + + transparentField + | gceTransparentFlag v = 0 `setBit` 0 + | otherwise = 0 + + packedFields = disposalField + .|. userInputField + .|. transparentField + + putWord8 packedFields + putWord16le $ gceDelay v + putWord8 $ gceTransparentColorIndex v + putWord8 0 -- blockTerminator + + get = do + -- due to missing lookahead + {-_extensionLabel <- getWord8-} + _size <- getWord8 + packedFields <- getWord8 + delay <- getWord16le + idx <- getWord8 + _blockTerminator <- getWord8 + return GraphicControlExtension + { gceDisposalMethod = + disposalMethodOfCode $ + (packedFields `unsafeShiftR` 2) .&. 0x07 + , gceUserInputFlag = packedFields `testBit` 1 + , gceTransparentFlag = packedFields `testBit` 0 + , gceDelay = delay + , gceTransparentColorIndex = idx + } + +data GifImage = GifImage + { imgDescriptor :: !ImageDescriptor + , imgLocalPalette :: !(Maybe Palette) + , imgLzwRootSize :: !Word8 + , imgData :: B.ByteString + } + +instance Binary GifImage where + put img = do + let descriptor = imgDescriptor img + put descriptor + case ( imgLocalPalette img + , gDescHasLocalMap $ imgDescriptor img) of + (Nothing, _) -> return () + (Just _, False) -> return () + (Just p, True) -> + putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p + putWord8 $ imgLzwRootSize img + putDataBlocks $ imgData img + + get = do + desc <- get + let hasLocalColorTable = gDescHasLocalMap desc + palette <- if hasLocalColorTable + then Just <$> getPalette (gDescLocalColorTableSize desc) + else pure Nothing + + GifImage desc palette <$> getWord8 <*> parseDataBlocks + +data Block = BlockImage GifImage + | BlockGraphicControl GraphicControlExtension + +skipSubDataBlocks :: Get () +skipSubDataBlocks = do + s <- fromIntegral <$> getWord8 + unless (s == 0) $ + skip s >> skipSubDataBlocks + +parseGifBlocks :: Get [Block] +parseGifBlocks = getWord8 >>= blockParse + where + blockParse v + | v == gifTrailer = pure [] + | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks + | v == extensionIntroducer = getWord8 >>= extensionParse + + blockParse v = do + readPosition <- bytesRead + fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) + + extensionParse code + | code == graphicControlLabel = + (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + | code == commentLabel = skipSubDataBlocks >> parseGifBlocks + | code `elem` [plainTextLabel, applicationLabel] = + fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks + | otherwise = parseDataBlocks >> parseGifBlocks + + +instance Binary ImageDescriptor where + put v = do + putWord8 imageSeparator + putWord16le $ gDescPixelsFromLeft v + putWord16le $ gDescPixelsFromTop v + putWord16le $ gDescImageWidth v + putWord16le $ gDescImageHeight v + let localMapField + | gDescHasLocalMap v = 0 `setBit` 7 + | otherwise = 0 + + isInterlacedField + | gDescIsInterlaced v = 0 `setBit` 6 + | otherwise = 0 + + isImageDescriptorSorted + | gDescIsImgDescriptorSorted v = 0 `setBit` 5 + | otherwise = 0 + + localSize = gDescLocalColorTableSize v + tableSizeField + | localSize > 0 = (localSize - 1) .&. 0x7 + | otherwise = 0 + + packedFields = localMapField + .|. isInterlacedField + .|. isImageDescriptorSorted + .|. tableSizeField + putWord8 packedFields + + get = do + -- due to missing lookahead + {-_imageSeparator <- getWord8-} + imgLeftPos <- getWord16le + imgTopPos <- getWord16le + imgWidth <- getWord16le + imgHeight <- getWord16le + packedFields <- getWord8 + let tableSize = packedFields .&. 0x7 + return ImageDescriptor + { gDescPixelsFromLeft = imgLeftPos + , gDescPixelsFromTop = imgTopPos + , gDescImageWidth = imgWidth + , gDescImageHeight = imgHeight + , gDescHasLocalMap = packedFields `testBit` 7 + , gDescIsInterlaced = packedFields `testBit` 6 + , gDescIsImgDescriptorSorted = packedFields `testBit` 5 + , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 + } + + +-------------------------------------------------- +---- Palette +-------------------------------------------------- +getPalette :: Word8 -> Get Palette +getPalette bitDepth = + Image size 1 . V.fromList <$> replicateM (size * 3) get + where size = 2 ^ (fromIntegral bitDepth :: Int) + +putPalette :: Int -> Palette -> Put +putPalette size pal = do + V.mapM_ putWord8 (imageData pal) + replicateM_ missingColorComponent (putWord8 0) + where elemCount = 2 ^ size + missingColorComponent = (elemCount - imageWidth pal) * 3 + +-------------------------------------------------- +---- GifImage +-------------------------------------------------- +data GifHeader = GifHeader + { gifVersion :: GifVersion + , gifScreenDescriptor :: LogicalScreenDescriptor + , gifGlobalMap :: !Palette + } + +instance Binary GifHeader where + put v = do + put $ gifVersion v + let descr = gifScreenDescriptor v + put descr + putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v + + get = do + version <- get + screenDesc <- get + + palette <- + if hasGlobalMap screenDesc then + getPalette $ colorTableSize screenDesc + else + return greyPalette + + return GifHeader + { gifVersion = version + , gifScreenDescriptor = screenDesc + , gifGlobalMap = palette + } + +data GifFile = GifFile + { gifHeader :: !GifHeader + , gifImages :: [(Maybe GraphicControlExtension, GifImage)] + , gifLoopingBehaviour :: GifLooping + } + +putLooping :: GifLooping -> Put +putLooping LoopingNever = return () +putLooping LoopingForever = putLooping $ LoopingRepeat 0 +putLooping (LoopingRepeat count) = do + putWord8 extensionIntroducer + putWord8 applicationLabel + putWord8 11 -- the size + putByteString $ BC.pack "NETSCAPE2.0" + putWord8 3 -- size of sub block + putWord8 1 + putWord16le count + putWord8 0 + +associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] +associateDescr [] = [] +associateDescr [BlockGraphicControl _] = [] +associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = + associateDescr rest +associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs +associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = + (Just ctrl, img) : associateDescr xs + +instance Binary GifFile where + put v = do + put $ gifHeader v + let putter (Nothing, i) = put i + putter (Just a, i) = put a >> put i + putLooping $ gifLoopingBehaviour v + mapM_ putter $ gifImages v + put gifTrailer + + get = do + hdr <- get + blocks <- parseGifBlocks + return GifFile { gifHeader = hdr + , gifImages = associateDescr blocks + , gifLoopingBehaviour = LoopingNever + } + +substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 +substituteColors palette = pixelMap swaper + where swaper n = pixelAt palette (fromIntegral n) 0 + +substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 +substituteColorsWithTransparency transparent palette = pixelMap swaper where + swaper n | ix == transparent = PixelRGBA8 0 0 0 0 + | otherwise = promotePixel $ pixelAt palette ix 0 + where ix = fromIntegral n + + +decodeImage :: GifImage -> Image Pixel8 +decodeImage img = runST $ runBoolReader $ do + outputVector <- lift . M.new $ width * height + decodeLzw (imgData img) 12 lzwRoot outputVector + frozenData <- lift $ V.unsafeFreeze outputVector + return . deinterlaceGif $ Image + { imageWidth = width + , imageHeight = height + , imageData = frozenData + } + where lzwRoot = fromIntegral $ imgLzwRootSize img + width = fromIntegral $ gDescImageWidth descriptor + height = fromIntegral $ gDescImageHeight descriptor + isInterlaced = gDescIsInterlaced descriptor + descriptor = imgDescriptor img + + deinterlaceGif | not isInterlaced = id + | otherwise = deinterlaceGifImage + +deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 +deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h + where lineIndices = gifInterlacingIndices h + generator x y = pixelAt img x y' + where y' = lineIndices V.! y + +gifInterlacingIndices :: Int -> V.Vector Int +gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices + where indices = flip zip [0..] $ + concat [ [0, 8 .. height - 1] + , [4, 4 + 8 .. height - 1] + , [2, 2 + 4 .. height - 1] + , [1, 1 + 2 .. height - 1] + ] + +paletteOf :: (ColorConvertible PixelRGB8 px) + => Image px -> GifImage -> Image px +paletteOf global GifImage { imgLocalPalette = Nothing } = global +paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p + +getFrameDelays :: GifFile -> [GifDelay] +getFrameDelays GifFile { gifImages = [] } = [] +getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs + where extractDelay (ext, _) = + case ext of + Nothing -> 0 + Just e -> fromIntegral $ gceDelay e + +transparentColorOf :: Maybe GraphicControlExtension -> Int +transparentColorOf Nothing = 300 +transparentColorOf (Just ext) + | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext + | otherwise = 300 + +hasTransparency :: Maybe GraphicControlExtension -> Bool +hasTransparency Nothing = False +hasTransparency (Just control) = gceTransparentFlag control + +decodeAllGifImages :: GifFile -> [DynamicImage] +decodeAllGifImages GifFile { gifImages = [] } = [] +decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette + , gifScreenDescriptor = wholeDescriptor } + , gifImages = (firstControl, firstImage) : rest } + | not (hasTransparency firstControl) = + let backImage = + generateImage (\_ _ -> backgroundColor) globalWidth globalHeight + thisPalette = paletteOf palette firstImage + initState = + (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage) + scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage + in + [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest] + + | otherwise = + let backImage :: Image PixelRGBA8 + backImage = + generateImage (\_ _ -> transparentBackground) globalWidth globalHeight + + thisPalette :: Image PixelRGBA8 + thisPalette = paletteOf (promoteImage palette) firstImage + + transparentCode = transparentColorOf firstControl + decoded = + substituteColorsWithTransparency transparentCode thisPalette $ + decodeImage firstImage + + initState = (thisPalette, firstControl, decoded) + scanner = + gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in + [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] + + where + globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor + + transparentBackground = PixelRGBA8 r g b 0 + where PixelRGB8 r g b = backgroundColor + + backgroundColor + | hasGlobalMap wholeDescriptor = + pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + | otherwise = PixelRGB8 0 0 0 + +gifAnimationApplyer :: forall px. + (Pixel px, ColorConvertible PixelRGB8 px) + => (Int, Int) -> Image px -> Image px + -> (Image px, Maybe GraphicControlExtension, Image px) + -> (Maybe GraphicControlExtension, GifImage) + -> (Image px, Maybe GraphicControlExtension, Image px) +gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage + (_, prevControl, img1) + (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (thisPalette, controlExt, thisImage) + where + thisPalette :: Image px + thisPalette = paletteOf globalPalette img2 + + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor + + left = fromIntegral $ gDescPixelsFromLeft descriptor + top = fromIntegral $ gDescPixelsFromTop descriptor + + isPixelInLocalImage x y = + x >= left && x < left + localWidth && y >= top && y < top + localHeight + + decoded :: Image Pixel8 + decoded = decodeImage img2 + + transparent :: Int + transparent = case controlExt of + Nothing -> 300 + Just ext -> if gceTransparentFlag ext + then fromIntegral $ gceTransparentColorIndex ext + else 300 + + oldImage = case gceDisposalMethod <$> prevControl of + Nothing -> img1 + Just DisposalAny -> img1 + Just DisposalDoNot -> img1 + Just DisposalRestoreBackground -> backgroundImage + Just DisposalRestorePrevious -> img1 + Just (DisposalUnknown _) -> img1 + + pixeler x y + | isPixelInLocalImage x y && code /= transparent = val where + code = fromIntegral $ pixelAt decoded (x - left) (y - top) + val = pixelAt thisPalette (fromIntegral code) 0 + pixeler x y = pixelAt oldImage x y + +decodeFirstGifImage :: GifFile -> Either String (DynamicImage, Metadatas) +decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = + case decodeAllGifImages img { gifImages = [firstImage] } of + [] -> Left "No image after decoding" + (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr)) + where hdr = gifScreenDescriptor $ gifHeader img +decodeFirstGifImage _ = Left "No image in gif file" + +-- | Transform a raw gif image to an image, witout +-- modifying the pixels. +-- This function can output the following pixel types : +-- +-- * PixelRGB8 +-- +-- * PixelRGBA8 +-- +decodeGif :: B.ByteString -> Either String DynamicImage +decodeGif img = decode img >>= (fmap fst . decodeFirstGifImage) + +-- | Transform a raw gif image to an image, witout +-- modifying the pixels. +-- This function can output the following pixel types : +-- +-- * PixelRGB8 +-- +-- * PixelRGBA8 +-- +-- Metadatas include Width & Height information. +-- +decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeGifWithMetadata img = decode img >>= decodeFirstGifImage + + +-- | Transform a raw gif to a list of images, representing +-- all the images of an animation. +decodeGifImages :: B.ByteString -> Either String [DynamicImage] +decodeGifImages img = decodeAllGifImages <$> decode img + +-- | Extract a list of frame delays from a raw gif. +getDelaysGifImages :: B.ByteString -> Either String [GifDelay] +getDelaysGifImages img = getFrameDelays <$> decode img + +-- | Default palette to produce greyscale images. +greyPalette :: Palette +greyPalette = generateImage toGrey 256 1 + where toGrey x _ = PixelRGB8 ix ix ix + where ix = fromIntegral x + +checkGifImageSizes :: [(a, b, Image px)] -> Bool +checkGifImageSizes [] = False +checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest + where width = imageWidth img + height = imageHeight img + + checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = + w == width && h == height + +checkPaletteValidity :: [(Palette, a, b)] -> Bool +checkPaletteValidity [] = False +checkPaletteValidity lst = + and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst + , let w = imageWidth p + h = imageHeight p ] + +areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool +areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img + where paletteElemCount = imageWidth palette + isTooBig v = fromIntegral v >= paletteElemCount + +computeMinimumLzwKeySize :: Palette -> Int +computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 + where go k | 2 ^ k >= itemCount = k + | otherwise = go $ k + 1 + +-- | Encode a gif animation to a bytestring. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String L.ByteString +encodeGifImages _ [] = Left "No image in list" +encodeGifImages _ imageList + | not $ checkGifImageSizes imageList = Left "Gif images have different size" + | not $ checkPaletteValidity imageList = + Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] + | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile + where + allFile = GifFile + { gifHeader = GifHeader + { gifVersion = GIF89a + , gifScreenDescriptor = logicalScreen + , gifGlobalMap = firstPalette + } + , gifImages = toSerialize + , gifLoopingBehaviour = looping + } + + logicalScreen = LogicalScreenDescriptor + { screenWidth = fromIntegral $ imageWidth firstImage + , screenHeight = fromIntegral $ imageHeight firstImage + , backgroundIndex = 0 + , hasGlobalMap = True + , colorResolution = 8 + , isColorTableSorted = False + , colorTableSize = 8 + } + + paletteEqual p = imageData firstPalette == imageData p + + controlExtension 0 = Nothing + controlExtension delay = Just GraphicControlExtension + { gceDisposalMethod = DisposalAny + , gceUserInputFlag = False + , gceTransparentFlag = False + , gceDelay = fromIntegral delay + , gceTransparentColorIndex = 0 + } + + toSerialize = [(controlExtension delay, GifImage + { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img + , imgLocalPalette = Just palette + , imgLzwRootSize = fromIntegral lzwKeySize + , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img + }) | (palette, delay, img) <- imageList + , let lzwKeySize = computeMinimumLzwKeySize palette + ] + + imageDescriptor paletteSize palEqual img = ImageDescriptor + { gDescPixelsFromLeft = 0 + , gDescPixelsFromTop = 0 + , gDescImageWidth = fromIntegral $ imageWidth img + , gDescImageHeight = fromIntegral $ imageHeight img + , gDescHasLocalMap = paletteSize > 0 && not palEqual + , gDescIsInterlaced = False + , gDescIsImgDescriptorSorted = False + , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize + } + +-- | Encode a greyscale image to a bytestring. +encodeGifImage :: Image Pixel8 -> L.ByteString +encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of + Left err -> error $ "Impossible:" ++ err + Right v -> v + +-- | Encode an image with a given palette. +-- Can return errors if the palette is ill-formed. +-- +-- * A palette must have between 1 and 256 colors +-- +encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString +encodeGifImageWithPalette img palette = + encodeGifImages LoopingNever [(palette, 0, img)] + +-- | Write a greyscale in a gif file on the disk. +writeGifImage :: FilePath -> Image Pixel8 -> IO () +writeGifImage file = L.writeFile file . encodeGifImage + +-- | Write a list of images as a gif animation in a file. +-- +-- * Every image must have the same size +-- +-- * Every palette must have between one and 256 colors. +-- +writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] + -> Either String (IO ()) +writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst + +-- | Write a gif image with a palette to a file. +-- +-- * A palette must have between 1 and 256 colors +-- +writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette + -> Either String (IO ()) +writeGifImageWithPalette file img palette = + L.writeFile file <$> encodeGifImageWithPalette img palette + diff --git a/src/Codec/Picture/HDR.hs b/src/Codec/Picture/HDR.hs --- a/src/Codec/Picture/HDR.hs +++ b/src/Codec/Picture/HDR.hs @@ -1,521 +1,531 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} --- | Module dedicated of Radiance file decompression (.hdr or .pic) file. --- Radiance file format is used for High dynamic range imaging. -module Codec.Picture.HDR( decodeHDR - , encodeHDR - , encodeRawHDR - , encodeRLENewStyleHDR - , writeHDR - , writeRLENewStyleHDR - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure, (<*>), (<$>) ) -#endif - -import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) -import Data.Char( ord, chr, isDigit ) -import Data.Word( Word8 ) -import Data.Monoid( (<>) ) -import Control.Monad( when, foldM, foldM_, forM, forM_, unless ) -import Control.Monad.Trans.Class( lift ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString.Char8 as BC - -import Data.List( partition ) -import Data.Binary( Binary( .. ), encode ) -import Data.Binary.Get( Get, getByteString, getWord8 ) -import Data.Binary.Put( putByteString, putLazyByteString ) - -import Control.Monad.ST( ST, runST ) -import Foreign.Storable ( Storable ) -import Control.Monad.Primitive ( PrimState, PrimMonad ) -import qualified Data.Vector.Storable as V -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.InternalHelper -import Codec.Picture.Types -import Codec.Picture.VectorByteConversion - -#if MIN_VERSION_transformers(0, 4, 0) -import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT ) -#else --- Transfomers 0.3 compat -import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT ) - -type ExceptT = ErrorT - -throwE :: (Monad m, Error e) => e -> ErrorT e m a -throwE = throwError - -runExceptT :: ErrorT e m a -> m (Either e a) -runExceptT = runErrorT -#endif - -{-# INLINE (.<<.) #-} -(.<<.), (.>>.) :: (Bits a) => a -> Int -> a -(.<<.) = unsafeShiftL -(.>>.) = unsafeShiftR - -{-# INLINE (.<-.) #-} -(.<-.) :: (PrimMonad m, Storable a) - => M.STVector (PrimState m) a -> Int -> a -> m () -(.<-.) = M.write - {-M.unsafeWrite-} - -type HDRReader s a = ExceptT String (ST s) a - -data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 - -instance Binary RGBE where - put (RGBE r g b e) = put r >> put g >> put b >> put e - get = RGBE <$> get <*> get <*> get <*> get - -checkLineLength :: RGBE -> Int -checkLineLength (RGBE _ _ a b) = - (fromIntegral a .<<. 8) .|. fromIntegral b - -isNewRunLengthMarker :: RGBE -> Bool -isNewRunLengthMarker (RGBE 2 2 _ _) = True -isNewRunLengthMarker _ = False - -data RadianceFormat = - FormatRGBE - | FormatXYZE - -radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString -radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" -radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" - -instance Binary RadianceFormat where - put FormatRGBE = putByteString radiance32bitRleRGBEFormat - put FormatXYZE = putByteString radiance32bitRleXYZEFromat - - get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format - where format sig - | sig == radiance32bitRleRGBEFormat = pure FormatRGBE - | sig == radiance32bitRleXYZEFromat = pure FormatXYZE - | otherwise = fail "Unrecognized Radiance format" - -toRGBE :: PixelRGBF -> RGBE -toRGBE (PixelRGBF r g b) - | d <= 1e-32 = RGBE 0 0 0 0 - | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) - where d = maximum [r, g, b] - e = exponent d - coeff = significand d * 255.9999 / d - fix v = truncate $ v * coeff - - -dropUntil :: Word8 -> Get () -dropUntil c = getWord8 >>= inner - where inner val | val == c = pure () - inner _ = getWord8 >>= inner - -getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString -getUntil f initialAcc = getWord8 >>= inner initialAcc - where inner acc c | f c = pure acc - inner acc c = getWord8 >>= inner (B.snoc acc c) - -data RadianceHeader = RadianceHeader - { radianceInfos :: [(B.ByteString, B.ByteString)] - , radianceFormat :: RadianceFormat - , radianceHeight :: !Int - , radianceWidth :: !Int - , radianceData :: L.ByteString - } - -radianceFileSignature :: B.ByteString -radianceFileSignature = BC.pack "#?RADIANCE\n" - -unpackColor :: L.ByteString -> Int -> RGBE -unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) - where at n = L.index str . fromIntegral $ idx + n - -storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () -storeColor vec idx (RGBE r g b e) = do - (vec .<-. (idx + 0)) r - (vec .<-. (idx + 1)) g - (vec .<-. (idx + 2)) b - (vec .<-. (idx + 3)) e - -parsePair :: Char -> Get (B.ByteString, B.ByteString) -parsePair firstChar = do - let eol c = c == fromIntegral (ord '\n') - line <- getUntil eol B.empty - case BC.split '=' line of - [] -> pure (BC.singleton firstChar, B.empty) - [val] -> pure (BC.singleton firstChar, val) - [key, val] -> pure (BC.singleton firstChar <> key, val) - (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) - -decodeInfos :: Get [(B.ByteString, B.ByteString)] -decodeInfos = do - char <- getChar8 - case char of - -- comment - '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos - -- end of header, no more information - '\n' -> pure [] - -- Classical parsing - c -> (:) <$> parsePair c <*> decodeInfos - - --- | Decode an HDR (radiance) image, the resulting pixel --- type can be : --- --- * PixelRGBF --- -decodeHDR :: B.ByteString -> Either String DynamicImage -decodeHDR str = runST $ runExceptT $ - case runGet decodeHeader $ L.fromChunks [str] of - Left err -> throwE err - Right rez -> - ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) - -getChar8 :: Get Char -getChar8 = chr . fromIntegral <$> getWord8 - -isSign :: Char -> Bool -isSign c = c == '+' || c == '-' - -isAxisLetter :: Char -> Bool -isAxisLetter c = c == 'X' || c == 'Y' - -decodeNum :: Get Int -decodeNum = do - sign <- getChar8 - letter <- getChar8 - space <- getChar8 - - unless (isSign sign && isAxisLetter letter && space == ' ') - (fail "Invalid radiance size declaration") - - let numDec acc c | isDigit c = - getChar8 >>= numDec (acc * 10 + ord c - ord '0') - numDec acc _ - | sign == '-' = pure $ negate acc - | otherwise = pure acc - - getChar8 >>= numDec 0 - -copyPrevColor :: M.STVector s Word8 -> Int -> ST s () -copyPrevColor scanLine idx = do - r <- scanLine `M.unsafeRead` (idx - 4) - g <- scanLine `M.unsafeRead` (idx - 3) - b <- scanLine `M.unsafeRead` (idx - 2) - e <- scanLine `M.unsafeRead` (idx - 1) - - (scanLine `M.unsafeWrite` (idx + 0)) r - (scanLine `M.unsafeWrite` (idx + 1)) g - (scanLine `M.unsafeWrite` (idx + 2)) b - (scanLine `M.unsafeWrite` (idx + 3)) e - -oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 - -> HDRReader s Int -oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 - where maxOutput = M.length scanLine - maxInput = fromIntegral $ L.length inputData - - inner readIdx writeIdx _ - | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx - inner readIdx writeIdx shift = do - let color@(RGBE r g b e) = unpackColor inputData readIdx - isRun = r == 1 && g == 1 && b == 1 - - if not isRun - then do - lift $ storeColor scanLine writeIdx color - inner (readIdx + 4) (writeIdx + 4) 0 - - else do - let count = fromIntegral e .<<. shift - lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) - inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) - -newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 - -> HDRReader s Int -newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] - where dataAt idx - | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" - | otherwise = pure $ L.index inputData (fromIntegral idx) - - maxOutput = M.length scanline - maxInput = fromIntegral $ L.length inputData - stride = 4 - - - strideSet count destIndex _ | endIndex > maxOutput + stride = - throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" - where endIndex = destIndex + count * stride - strideSet count destIndex val = aux destIndex count - where aux i 0 = pure i - aux i c = do - lift $ (scanline .<-. i) val - aux (i + stride) (c - 1) - - - strideCopy _ count destIndex - | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" - where writeEndBound = destIndex + count * stride - strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count - where aux _ j 0 = pure j - aux i j c = do - val <- dataAt i - lift $ (scanline .<-. j) val - aux (i + 1) (j + stride) (c - 1) - - inner readIdx writeIdx - | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx - inner readIdx writeIdx = do - code <- dataAt readIdx - if code > 128 - then do - let repeatCount = fromIntegral code .&. 0x7F - newVal <- dataAt $ readIdx + 1 - endIndex <- strideSet repeatCount writeIdx newVal - inner (readIdx + 2) endIndex - - else do - let iCode = fromIntegral code - endIndex <- strideCopy (readIdx + 1) iCode writeIdx - inner (readIdx + iCode + 1) endIndex - -instance Binary RadianceHeader where - get = decodeHeader - put hdr = do - putByteString radianceFileSignature - putByteString $ BC.pack "FORMAT=" - put $ radianceFormat hdr - let sizeString = - BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) - ++ " +X " ++ show (radianceWidth hdr) ++ "\n" - putByteString sizeString - putLazyByteString $ radianceData hdr - - -decodeHeader :: Get RadianceHeader -decodeHeader = do - sig <- getByteString $ B.length radianceFileSignature - when (sig /= radianceFileSignature) - (fail "Invalid radiance file signature") - - infos <- decodeInfos - let formatKey = BC.pack "FORMAT" - case partition (\(k,_) -> k /= formatKey) infos of - (_, []) -> fail "No radiance format specified" - (info, [(_, formatString)]) -> - case runGet get $ L.fromChunks [formatString] of - Left err -> fail err - Right format -> do - (n1, n2, b) <- (,,) <$> decodeNum - <*> decodeNum - <*> getRemainingBytes - return . RadianceHeader info format n1 n2 $ L.fromChunks [b] - - _ -> fail "Multiple radiance format specified" - -toFloat :: RGBE -> PixelRGBF -toFloat (RGBE r g b e) = PixelRGBF rf gf bf - where f = encodeFloat 1 $ fromIntegral e - (128 + 8) - rf = (fromIntegral r + 0.0) * f - gf = (fromIntegral g + 0.0) * f - bf = (fromIntegral b + 0.0) * f - -encodeScanlineColor :: M.STVector s Word8 - -> M.STVector s Word8 - -> Int - -> ST s Int -encodeScanlineColor vec outVec outIdx = do - val <- vec `M.unsafeRead` 0 - runLength 1 0 val 1 outIdx - where maxIndex = M.length vec - - pushRun len val at = do - (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 - (outVec `M.unsafeWrite` (at + 1)) val - return $ at + 2 - - pushData start len at = do - (outVec `M.unsafeWrite` at) $ fromIntegral len - let first = start - len - end = start - 1 - offset = at - first + 1 - forM_ [first .. end] $ \i -> do - v <- vec `M.unsafeRead` i - (outVec `M.unsafeWrite` (offset + i)) v - - return $ at + len + 1 - - -- End of scanline, empty the thing - runLength run cpy prev idx at | idx >= maxIndex = - case (run, cpy) of - (0, 0) -> pure at - (0, n) -> pushData idx n at - (n, 0) -> pushRun n prev at - (_, _) -> error "HDR - Run length algorithm is wrong" - - -- full runlength, we must write the packet - runLength r@127 _ prev idx at = do - val <- vec `M.unsafeRead` idx - pushRun r prev at >>= - runLength 1 0 val (idx + 1) - - -- full copy, we must write the packet - runLength _ c@127 _ idx at = do - val <- vec `M.unsafeRead` idx - pushData idx c at >>= - runLength 1 0 val (idx + 1) - - runLength n 0 prev idx at = do - val <- vec `M.unsafeRead` idx - case val == prev of - True -> runLength (n + 1) 0 prev (idx + 1) at - False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at - False -> - pushRun n prev at >>= - runLength 1 0 val (idx + 1) - - runLength 0 n prev idx at = do - val <- vec `M.unsafeRead` idx - if val /= prev - then runLength 0 (n + 1) val (idx + 1) at - else - pushData (idx - 1) (n - 1) at >>= - runLength (2 :: Int) 0 val (idx + 1) - - runLength _ _ _ _ _ = - error "HDR RLE inconsistent state" - --- | Write an High dynamic range image into a radiance --- image file on disk. -writeHDR :: FilePath -> Image PixelRGBF -> IO () -writeHDR filename img = L.writeFile filename $ encodeHDR img - --- | Write a RLE encoded High dynamic range image into a radiance --- image file on disk. -writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO () -writeRLENewStyleHDR filename img = - L.writeFile filename $ encodeRLENewStyleHDR img - --- | Encode an High dynamic range image into a radiance image --- file format. --- Alias for encodeRawHDR -encodeHDR :: Image PixelRGBF -> L.ByteString -encodeHDR = encodeRawHDR - --- | Encode an High dynamic range image into a radiance image --- file format. without compression -encodeRawHDR :: Image PixelRGBF -> L.ByteString -encodeRawHDR pic = encode descriptor - where - newImage = pixelMap rgbeInRgba pic - -- we are cheating to death here, the layout we want - -- correspond to the layout of pixelRGBA8, so we - -- convert - rgbeInRgba pixel = PixelRGBA8 r g b e - where RGBE r g b e = toRGBE pixel - - descriptor = RadianceHeader - { radianceInfos = [] - , radianceFormat = FormatRGBE - , radianceHeight = imageHeight pic - , radianceWidth = imageWidth pic - , radianceData = L.fromChunks [toByteString $ imageData newImage] - } - - --- | Encode an High dynamic range image into a radiance image --- file format using a light RLE compression. Some problems --- seem to arise with some image viewer. -encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString -encodeRLENewStyleHDR pic = encode $ runST $ do - let w = imageWidth pic - h = imageHeight pic - - scanLineR <- M.new w :: ST s (M.STVector s Word8) - scanLineG <- M.new w - scanLineB <- M.new w - scanLineE <- M.new w - - encoded <- - forM [0 .. h - 1] $ \line -> do - buff <- M.new $ w * 4 + w `div` 127 + 2 - let columner col | col >= w = return () - columner col = do - let RGBE r g b e = toRGBE $ pixelAt pic col line - (scanLineR `M.unsafeWrite` col) r - (scanLineG `M.unsafeWrite` col) g - (scanLineB `M.unsafeWrite` col) b - (scanLineE `M.unsafeWrite` col) e - - columner (col + 1) - - columner 0 - - (buff `M.unsafeWrite` 0) 2 - (buff `M.unsafeWrite` 1) 2 - (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) - (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) - - i1 <- encodeScanlineColor scanLineR buff 4 - i2 <- encodeScanlineColor scanLineG buff i1 - i3 <- encodeScanlineColor scanLineB buff i2 - endIndex <- encodeScanlineColor scanLineE buff i3 - - (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff - - pure RadianceHeader - { radianceInfos = [] - , radianceFormat = FormatRGBE - , radianceHeight = h - , radianceWidth = w - , radianceData = L.fromChunks encoded - } - - -decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) -decodeRadiancePicture hdr = do - let width = abs $ radianceWidth hdr - height = abs $ radianceHeight hdr - packedData = radianceData hdr - - scanLine <- lift $ M.new $ width * 4 - resultBuffer <- lift $ M.new $ width * height * 3 - - let scanLineImage = MutableImage - { mutableImageWidth = width - , mutableImageHeight = 1 - , mutableImageData = scanLine - } - - finalImage = MutableImage - { mutableImageWidth = width - , mutableImageHeight = height - , mutableImageData = resultBuffer - } - - let scanLineExtractor readIdx line = do - let color = unpackColor packedData readIdx - inner | isNewRunLengthMarker color = do - let calcSize = checkLineLength color - when (calcSize /= width) - (throwE "Invalid sanline size") - pure $ \idx -> newStyleRLE packedData (idx + 4) - | otherwise = pure $ oldStyleRLE packedData - f <- inner - newRead <- f readIdx scanLine - forM_ [0 .. width - 1] $ \i -> do - -- mokay, it's a hack, but I don't want to define a - -- pixel instance of RGBE... - PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 - lift $ writePixel finalImage i line . toFloat $ RGBE r g b e - - return newRead - - foldM_ scanLineExtractor 0 [0 .. height - 1] - - return finalImage - +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TupleSections #-} +-- | Module dedicated of Radiance file decompression (.hdr or .pic) file. +-- Radiance file format is used for High dynamic range imaging. +module Codec.Picture.HDR( decodeHDR + , decodeHDRWithMetadata + , encodeHDR + , encodeRawHDR + , encodeRLENewStyleHDR + , writeHDR + , writeRLENewStyleHDR + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure, (<*>), (<$>) ) +#endif + +import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) +import Data.Char( ord, chr, isDigit ) +import Data.Word( Word8 ) +import Data.Monoid( (<>) ) +import Control.Monad( when, foldM, foldM_, forM, forM_, unless ) +import Control.Monad.Trans.Class( lift ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Char8 as BC + +import Data.List( partition ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get, getByteString, getWord8 ) +import Data.Binary.Put( putByteString, putLazyByteString ) + +import Control.Monad.ST( ST, runST ) +import Foreign.Storable ( Storable ) +import Control.Monad.Primitive ( PrimState, PrimMonad ) +import qualified Data.Vector.Storable as V +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceHDR ) + , basicMetadata ) +import Codec.Picture.InternalHelper +import Codec.Picture.Types +import Codec.Picture.VectorByteConversion + +#if MIN_VERSION_transformers(0, 4, 0) +import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT ) +#else +-- Transfomers 0.3 compat +import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT ) + +type ExceptT = ErrorT + +throwE :: (Monad m, Error e) => e -> ErrorT e m a +throwE = throwError + +runExceptT :: ErrorT e m a -> m (Either e a) +runExceptT = runErrorT +#endif + +{-# INLINE (.<<.) #-} +(.<<.), (.>>.) :: (Bits a) => a -> Int -> a +(.<<.) = unsafeShiftL +(.>>.) = unsafeShiftR + +{-# INLINE (.<-.) #-} +(.<-.) :: (PrimMonad m, Storable a) + => M.STVector (PrimState m) a -> Int -> a -> m () +(.<-.) = M.write + {-M.unsafeWrite-} + +type HDRReader s a = ExceptT String (ST s) a + +data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 + +instance Binary RGBE where + put (RGBE r g b e) = put r >> put g >> put b >> put e + get = RGBE <$> get <*> get <*> get <*> get + +checkLineLength :: RGBE -> Int +checkLineLength (RGBE _ _ a b) = + (fromIntegral a .<<. 8) .|. fromIntegral b + +isNewRunLengthMarker :: RGBE -> Bool +isNewRunLengthMarker (RGBE 2 2 _ _) = True +isNewRunLengthMarker _ = False + +data RadianceFormat = + FormatRGBE + | FormatXYZE + +radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString +radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" +radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" + +instance Binary RadianceFormat where + put FormatRGBE = putByteString radiance32bitRleRGBEFormat + put FormatXYZE = putByteString radiance32bitRleXYZEFromat + + get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format + where format sig + | sig == radiance32bitRleRGBEFormat = pure FormatRGBE + | sig == radiance32bitRleXYZEFromat = pure FormatXYZE + | otherwise = fail "Unrecognized Radiance format" + +toRGBE :: PixelRGBF -> RGBE +toRGBE (PixelRGBF r g b) + | d <= 1e-32 = RGBE 0 0 0 0 + | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) + where d = maximum [r, g, b] + e = exponent d + coeff = significand d * 255.9999 / d + fix v = truncate $ v * coeff + + +dropUntil :: Word8 -> Get () +dropUntil c = getWord8 >>= inner + where inner val | val == c = pure () + inner _ = getWord8 >>= inner + +getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString +getUntil f initialAcc = getWord8 >>= inner initialAcc + where inner acc c | f c = pure acc + inner acc c = getWord8 >>= inner (B.snoc acc c) + +data RadianceHeader = RadianceHeader + { radianceInfos :: [(B.ByteString, B.ByteString)] + , radianceFormat :: RadianceFormat + , radianceHeight :: !Int + , radianceWidth :: !Int + , radianceData :: L.ByteString + } + +radianceFileSignature :: B.ByteString +radianceFileSignature = BC.pack "#?RADIANCE\n" + +unpackColor :: L.ByteString -> Int -> RGBE +unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) + where at n = L.index str . fromIntegral $ idx + n + +storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () +storeColor vec idx (RGBE r g b e) = do + (vec .<-. (idx + 0)) r + (vec .<-. (idx + 1)) g + (vec .<-. (idx + 2)) b + (vec .<-. (idx + 3)) e + +parsePair :: Char -> Get (B.ByteString, B.ByteString) +parsePair firstChar = do + let eol c = c == fromIntegral (ord '\n') + line <- getUntil eol B.empty + case BC.split '=' line of + [] -> pure (BC.singleton firstChar, B.empty) + [val] -> pure (BC.singleton firstChar, val) + [key, val] -> pure (BC.singleton firstChar <> key, val) + (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) + +decodeInfos :: Get [(B.ByteString, B.ByteString)] +decodeInfos = do + char <- getChar8 + case char of + -- comment + '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos + -- end of header, no more information + '\n' -> pure [] + -- Classical parsing + c -> (:) <$> parsePair c <*> decodeInfos + + +-- | Decode an HDR (radiance) image, the resulting pixel +-- type can be : +-- +-- * PixelRGBF +-- +decodeHDR :: B.ByteString -> Either String DynamicImage +decodeHDR = fmap fst . decodeHDRWithMetadata + +-- | Equivalent to decodeHDR but with aditional metadatas. +decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeHDRWithMetadata str = runST $ runExceptT $ + case runGet decodeHeader $ L.fromChunks [str] of + Left err -> throwE err + Right rez -> + let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $ radianceHeight rez) in + (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) + +getChar8 :: Get Char +getChar8 = chr . fromIntegral <$> getWord8 + +isSign :: Char -> Bool +isSign c = c == '+' || c == '-' + +isAxisLetter :: Char -> Bool +isAxisLetter c = c == 'X' || c == 'Y' + +decodeNum :: Get Int +decodeNum = do + sign <- getChar8 + letter <- getChar8 + space <- getChar8 + + unless (isSign sign && isAxisLetter letter && space == ' ') + (fail "Invalid radiance size declaration") + + let numDec acc c | isDigit c = + getChar8 >>= numDec (acc * 10 + ord c - ord '0') + numDec acc _ + | sign == '-' = pure $ negate acc + | otherwise = pure acc + + getChar8 >>= numDec 0 + +copyPrevColor :: M.STVector s Word8 -> Int -> ST s () +copyPrevColor scanLine idx = do + r <- scanLine `M.unsafeRead` (idx - 4) + g <- scanLine `M.unsafeRead` (idx - 3) + b <- scanLine `M.unsafeRead` (idx - 2) + e <- scanLine `M.unsafeRead` (idx - 1) + + (scanLine `M.unsafeWrite` (idx + 0)) r + (scanLine `M.unsafeWrite` (idx + 1)) g + (scanLine `M.unsafeWrite` (idx + 2)) b + (scanLine `M.unsafeWrite` (idx + 3)) e + +oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 + where maxOutput = M.length scanLine + maxInput = fromIntegral $ L.length inputData + + inner readIdx writeIdx _ + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx shift = do + let color@(RGBE r g b e) = unpackColor inputData readIdx + isRun = r == 1 && g == 1 && b == 1 + + if not isRun + then do + lift $ storeColor scanLine writeIdx color + inner (readIdx + 4) (writeIdx + 4) 0 + + else do + let count = fromIntegral e .<<. shift + lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) + inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) + +newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] + where dataAt idx + | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" + | otherwise = pure $ L.index inputData (fromIntegral idx) + + maxOutput = M.length scanline + maxInput = fromIntegral $ L.length inputData + stride = 4 + + + strideSet count destIndex _ | endIndex > maxOutput + stride = + throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" + where endIndex = destIndex + count * stride + strideSet count destIndex val = aux destIndex count + where aux i 0 = pure i + aux i c = do + lift $ (scanline .<-. i) val + aux (i + stride) (c - 1) + + + strideCopy _ count destIndex + | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" + where writeEndBound = destIndex + count * stride + strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count + where aux _ j 0 = pure j + aux i j c = do + val <- dataAt i + lift $ (scanline .<-. j) val + aux (i + 1) (j + stride) (c - 1) + + inner readIdx writeIdx + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx = do + code <- dataAt readIdx + if code > 128 + then do + let repeatCount = fromIntegral code .&. 0x7F + newVal <- dataAt $ readIdx + 1 + endIndex <- strideSet repeatCount writeIdx newVal + inner (readIdx + 2) endIndex + + else do + let iCode = fromIntegral code + endIndex <- strideCopy (readIdx + 1) iCode writeIdx + inner (readIdx + iCode + 1) endIndex + +instance Binary RadianceHeader where + get = decodeHeader + put hdr = do + putByteString radianceFileSignature + putByteString $ BC.pack "FORMAT=" + put $ radianceFormat hdr + let sizeString = + BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) + ++ " +X " ++ show (radianceWidth hdr) ++ "\n" + putByteString sizeString + putLazyByteString $ radianceData hdr + + +decodeHeader :: Get RadianceHeader +decodeHeader = do + sig <- getByteString $ B.length radianceFileSignature + when (sig /= radianceFileSignature) + (fail "Invalid radiance file signature") + + infos <- decodeInfos + let formatKey = BC.pack "FORMAT" + case partition (\(k,_) -> k /= formatKey) infos of + (_, []) -> fail "No radiance format specified" + (info, [(_, formatString)]) -> + case runGet get $ L.fromChunks [formatString] of + Left err -> fail err + Right format -> do + (n1, n2, b) <- (,,) <$> decodeNum + <*> decodeNum + <*> getRemainingBytes + return . RadianceHeader info format n1 n2 $ L.fromChunks [b] + + _ -> fail "Multiple radiance format specified" + +toFloat :: RGBE -> PixelRGBF +toFloat (RGBE r g b e) = PixelRGBF rf gf bf + where f = encodeFloat 1 $ fromIntegral e - (128 + 8) + rf = (fromIntegral r + 0.0) * f + gf = (fromIntegral g + 0.0) * f + bf = (fromIntegral b + 0.0) * f + +encodeScanlineColor :: M.STVector s Word8 + -> M.STVector s Word8 + -> Int + -> ST s Int +encodeScanlineColor vec outVec outIdx = do + val <- vec `M.unsafeRead` 0 + runLength 1 0 val 1 outIdx + where maxIndex = M.length vec + + pushRun len val at = do + (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 + (outVec `M.unsafeWrite` (at + 1)) val + return $ at + 2 + + pushData start len at = do + (outVec `M.unsafeWrite` at) $ fromIntegral len + let first = start - len + end = start - 1 + offset = at - first + 1 + forM_ [first .. end] $ \i -> do + v <- vec `M.unsafeRead` i + (outVec `M.unsafeWrite` (offset + i)) v + + return $ at + len + 1 + + -- End of scanline, empty the thing + runLength run cpy prev idx at | idx >= maxIndex = + case (run, cpy) of + (0, 0) -> pure at + (0, n) -> pushData idx n at + (n, 0) -> pushRun n prev at + (_, _) -> error "HDR - Run length algorithm is wrong" + + -- full runlength, we must write the packet + runLength r@127 _ prev idx at = do + val <- vec `M.unsafeRead` idx + pushRun r prev at >>= + runLength 1 0 val (idx + 1) + + -- full copy, we must write the packet + runLength _ c@127 _ idx at = do + val <- vec `M.unsafeRead` idx + pushData idx c at >>= + runLength 1 0 val (idx + 1) + + runLength n 0 prev idx at = do + val <- vec `M.unsafeRead` idx + case val == prev of + True -> runLength (n + 1) 0 prev (idx + 1) at + False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at + False -> + pushRun n prev at >>= + runLength 1 0 val (idx + 1) + + runLength 0 n prev idx at = do + val <- vec `M.unsafeRead` idx + if val /= prev + then runLength 0 (n + 1) val (idx + 1) at + else + pushData (idx - 1) (n - 1) at >>= + runLength (2 :: Int) 0 val (idx + 1) + + runLength _ _ _ _ _ = + error "HDR RLE inconsistent state" + +-- | Write an High dynamic range image into a radiance +-- image file on disk. +writeHDR :: FilePath -> Image PixelRGBF -> IO () +writeHDR filename img = L.writeFile filename $ encodeHDR img + +-- | Write a RLE encoded High dynamic range image into a radiance +-- image file on disk. +writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO () +writeRLENewStyleHDR filename img = + L.writeFile filename $ encodeRLENewStyleHDR img + +-- | Encode an High dynamic range image into a radiance image +-- file format. +-- Alias for encodeRawHDR +encodeHDR :: Image PixelRGBF -> L.ByteString +encodeHDR = encodeRawHDR + +-- | Encode an High dynamic range image into a radiance image +-- file format. without compression +encodeRawHDR :: Image PixelRGBF -> L.ByteString +encodeRawHDR pic = encode descriptor + where + newImage = pixelMap rgbeInRgba pic + -- we are cheating to death here, the layout we want + -- correspond to the layout of pixelRGBA8, so we + -- convert + rgbeInRgba pixel = PixelRGBA8 r g b e + where RGBE r g b e = toRGBE pixel + + descriptor = RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = imageHeight pic + , radianceWidth = imageWidth pic + , radianceData = L.fromChunks [toByteString $ imageData newImage] + } + + +-- | Encode an High dynamic range image into a radiance image +-- file format using a light RLE compression. Some problems +-- seem to arise with some image viewer. +encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString +encodeRLENewStyleHDR pic = encode $ runST $ do + let w = imageWidth pic + h = imageHeight pic + + scanLineR <- M.new w :: ST s (M.STVector s Word8) + scanLineG <- M.new w + scanLineB <- M.new w + scanLineE <- M.new w + + encoded <- + forM [0 .. h - 1] $ \line -> do + buff <- M.new $ w * 4 + w `div` 127 + 2 + let columner col | col >= w = return () + columner col = do + let RGBE r g b e = toRGBE $ pixelAt pic col line + (scanLineR `M.unsafeWrite` col) r + (scanLineG `M.unsafeWrite` col) g + (scanLineB `M.unsafeWrite` col) b + (scanLineE `M.unsafeWrite` col) e + + columner (col + 1) + + columner 0 + + (buff `M.unsafeWrite` 0) 2 + (buff `M.unsafeWrite` 1) 2 + (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) + (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) + + i1 <- encodeScanlineColor scanLineR buff 4 + i2 <- encodeScanlineColor scanLineG buff i1 + i3 <- encodeScanlineColor scanLineB buff i2 + endIndex <- encodeScanlineColor scanLineE buff i3 + + (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff + + pure RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = h + , radianceWidth = w + , radianceData = L.fromChunks encoded + } + + +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) +decodeRadiancePicture hdr = do + let width = abs $ radianceWidth hdr + height = abs $ radianceHeight hdr + packedData = radianceData hdr + + scanLine <- lift $ M.new $ width * 4 + resultBuffer <- lift $ M.new $ width * height * 3 + + let scanLineImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = 1 + , mutableImageData = scanLine + } + + finalImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = height + , mutableImageData = resultBuffer + } + + let scanLineExtractor readIdx line = do + let color = unpackColor packedData readIdx + inner | isNewRunLengthMarker color = do + let calcSize = checkLineLength color + when (calcSize /= width) + (throwE "Invalid sanline size") + pure $ \idx -> newStyleRLE packedData (idx + 4) + | otherwise = pure $ oldStyleRLE packedData + f <- inner + newRead <- f readIdx scanLine + forM_ [0 .. width - 1] $ \i -> do + -- mokay, it's a hack, but I don't want to define a + -- pixel instance of RGBE... + PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 + lift $ writePixel finalImage i line . toFloat $ RGBE r g b e + + return newRead + + foldM_ scanLineExtractor 0 [0 .. height - 1] + + return finalImage + diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -47,7 +47,9 @@ import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types -import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceJpeg ) + , basicMetadata ) import Codec.Picture.Tiff.Types import Codec.Picture.Tiff.Metadata import Codec.Picture.Jpg.Types @@ -567,13 +569,15 @@ let (st, arr) = decodeBaseline jfifMeta = foldMap extractMetadatas $ app0JFifMarker st exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st - meta = jfifMeta <> exifMeta + meta = sizeMeta <> jfifMeta <> exifMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr Just ProgressiveDCT -> let (st, arr) = decodeProgressive - meta = foldMap extractMetadatas $ app0JFifMarker st + jfifMeta = foldMap extractMetadatas $ app0JFifMarker st + exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st + meta = sizeMeta <> jfifMeta <> exifMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr @@ -585,6 +589,8 @@ imgKind = gatherImageKind $ jpgFrame img imgWidth = fromIntegral $ jpgWidth scanInfo imgHeight = fromIntegral $ jpgHeight scanInfo + + sizeMeta = basicMetadata SourceJpeg imgWidth imgHeight imageSize = imgWidth * imgHeight * compCount diff --git a/src/Codec/Picture/Metadata.hs b/src/Codec/Picture/Metadata.hs --- a/src/Codec/Picture/Metadata.hs +++ b/src/Codec/Picture/Metadata.hs @@ -16,6 +16,7 @@ , Keys( .. ) , Value( .. ) , Elem( .. ) + , SourceFormat( .. ) -- * Functions , Codec.Picture.Metadata.lookup @@ -30,6 +31,9 @@ -- * Helper functions , mkDpiMetadata + , mkSizeMetadata + , basicMetadata + , simpleMetadata -- * Conversion functions , dotsPerMeterToDotPerInch @@ -56,6 +60,20 @@ Refl :: Equiv a a #endif +-- | Type describing the original file format of the ilfe. +data SourceFormat + = SourceJpeg + | SourceGif + | SourceBitmap + | SourceTiff + | SourcePng + | SourceHDR + | SourceTGA + deriving (Eq, Show) + +instance NFData SourceFormat where + rnf a = a `seq` () + -- | Store various additional information about an image. If -- something is not recognized, it can be stored in an unknown tag. -- @@ -63,14 +81,25 @@ -- -- * 'DpiY' Dot per inch on this y axis. -- +-- * 'Width' Image width in pixel. Relying on the metadata for this +-- information can avoid the full decompression of the image. +-- Ignored for image writing. +-- +-- * 'Height' Image height in pixels. Relyiung on the metadata for this +-- information can void the full decomrpession of the image. +-- Ignored for image writing. +-- -- * 'Unknown' unlikely to be decoded, but usefull for metadata writing -- -- * 'Exif' Exif tag and associated data. -- data Keys a where Gamma :: Keys Double + Format :: Keys SourceFormat DpiX :: Keys Word DpiY :: Keys Word + Width :: Keys Word + Height :: Keys Word Title :: Keys String Description :: Keys String Author :: Keys String @@ -112,6 +141,8 @@ (Gamma, Gamma) -> Just Refl (DpiX, DpiX) -> Just Refl (DpiY, DpiY) -> Just Refl + (Width, Width) -> Just Refl + (Height, Height) -> Just Refl (Title, Title) -> Just Refl (Description, Description) -> Just Refl (Author, Author) -> Just Refl @@ -121,6 +152,7 @@ (Disclaimer, Disclaimer) -> Just Refl (Source, Source) -> Just Refl (Warning, Warning) -> Just Refl + (Format, Format) -> Just Refl (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl (Exif t1, Exif t2) | t1 == t2 -> Just Refl _ -> Nothing @@ -198,5 +230,30 @@ -- | Create metadatas indicating the resolution, with DpiX == DpiY mkDpiMetadata :: Word -> Metadatas -mkDpiMetadata w = insert DpiY w $ singleton DpiX w +mkDpiMetadata w = + Metadatas [DpiY :=> w, DpiX :=> w] + +-- | Create metadatas holding width and height information. +mkSizeMetadata :: Integral n => n -> n -> Metadatas +mkSizeMetadata w h = + Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ] + +-- | Create simple metadatas with Format, Width & Height +basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas +basicMetadata f w h = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + ] + +-- | Create simple metadatas with Format, Width, Height, DpiX & DpiY +simpleMetadata :: (Integral nSize, Integral nDpi) + => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas +simpleMetadata f w h dpiX dpiY = + Metadatas [ Format :=> f + , Width :=> fromIntegral w + , Height :=> fromIntegral h + , DpiX :=> fromIntegral dpiX + , DpiY :=> fromIntegral dpiY + ] diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs --- a/src/Codec/Picture/Png.hs +++ b/src/Codec/Picture/Png.hs @@ -34,6 +34,7 @@ import Control.Monad( forM_, foldM_, when, void ) import Control.Monad.ST( ST, runST ) +import Data.Monoid( (<>) ) import Data.Binary( Binary( get) ) import qualified Data.Vector.Storable as V @@ -507,7 +508,8 @@ decodePngWithMetadata byte = do rawImg <- runGetStrict get byte let ihdr = header rawImg - metadatas = extractMetadatas rawImg + metadatas = + basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg compressedImageData = Lb.concat [chunkData chunk | chunk <- chunks rawImg , chunkType chunk == iDATSignature] diff --git a/src/Codec/Picture/Png/Metadata.hs b/src/Codec/Picture/Png/Metadata.hs --- a/src/Codec/Picture/Png/Metadata.hs +++ b/src/Codec/Picture/Png/Metadata.hs @@ -111,6 +111,9 @@ Met.Exif _ :=> _ -> mempty Met.DpiX :=> _ -> mempty Met.DpiY :=> _ -> mempty + Met.Width :=> _ -> mempty + Met.Height :=> _ -> mempty + Met.Format :=> _ -> mempty Met.Gamma :=> g -> pure $ mkRawChunk gammaSignature . encode $ PngGamma g Met.Title :=> tx -> txt "Title" (L.pack tx) diff --git a/src/Codec/Picture/Tga.hs b/src/Codec/Picture/Tga.hs --- a/src/Codec/Picture/Tga.hs +++ b/src/Codec/Picture/Tga.hs @@ -4,10 +4,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} -- | Module implementing function to read and write -- Targa (*.tga) files. module Codec.Picture.Tga( decodeTga + , decodeTgaWithMetadata , TgaSaveable , encodeTga , writeTga @@ -45,6 +47,9 @@ import Codec.Picture.Types import Codec.Picture.InternalHelper +import Codec.Picture.Metadata( Metadatas + , SourceFormat( SourceTGA ) + , basicMetadata ) import Codec.Picture.VectorByteConversion data TgaColorMapType @@ -271,7 +276,7 @@ applyPalette _ _ _ = fail "Bad colorspace for image" -unparse :: TgaFile -> Either String DynamicImage +unparse :: TgaFile -> Either String (DynamicImage, Metadatas) unparse file = let hdr = _tgaFileHeader file imageType = _tgaHdrImageType hdr @@ -281,6 +286,7 @@ unpacker | isRleEncoded imageType = unpackRLETga | otherwise = unpackUncompressedTga + metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr) decodedPalette = unparse file { _tgaFileHeader = hdr { _tgaHdrHeight = 1 @@ -294,18 +300,18 @@ case imageType of ImageTypeNoData _ -> fail "No data detected in TGA file" ImageTypeTrueColor _ -> - prepareUnpacker file unpacker + fmap (, metas) $ prepareUnpacker file unpacker ImageTypeMonochrome _ -> - prepareUnpacker file unpacker + fmap (, metas) $ 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 (ImageY8 img, _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageY8 img + Right (ImageRGB8 img, _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img + Right (ImageRGBA8 img, _) -> + fmap (, metas) $ prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img Right _ -> fail "Unknown pixel type" writeRun :: (Pixel px) @@ -444,7 +450,11 @@ -- * PixelRGBA8 -- decodeTga :: B.ByteString -> Either String DynamicImage -decodeTga byte = runGetStrict get byte >>= unparse +decodeTga byte = runGetStrict get byte >>= (fmap fst . unparse) + +-- | Equivalent to decodeTga but also provide metadata +decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeTgaWithMetadata byte = runGetStrict get byte >>= unparse -- | This typeclass determine if a pixel can be saved in the -- TGA format. diff --git a/src/Codec/Picture/Tiff/Metadata.hs b/src/Codec/Picture/Tiff/Metadata.hs --- a/src/Codec/Picture/Tiff/Metadata.hs +++ b/src/Codec/Picture/Tiff/Metadata.hs @@ -17,7 +17,7 @@ import Codec.Picture.Metadata.Exif extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas -extractTiffStringMetadata = foldMap go where +extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where strMeta k = Met.singleton k . B.unpack exif ifd = Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd @@ -31,8 +31,8 @@ (TagSoftware, ExifString v) -> strMeta Met.Software v (TagImageDescription, ExifString v) -> strMeta Met.Description v (TagCompression, _) -> mempty - (TagImageWidth, _) -> mempty - (TagImageLength, _) -> mempty + (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd + (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd (TagXResolution, _) -> mempty (TagYResolution, _) -> mempty (TagResolutionUnit, _) -> mempty