JuicyPixels 3.2.5.1 → 3.2.5.2
raw patch · 12 files changed
+1490/−1375 lines, 12 filesPVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
API changes (from Hackage documentation)
+ Codec.Picture.Gif: decodeGifWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
+ Codec.Picture.HDR: decodeHDRWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
+ Codec.Picture.Metadata: Format :: Keys SourceFormat
+ Codec.Picture.Metadata: Height :: Keys Word
+ Codec.Picture.Metadata: SourceBitmap :: SourceFormat
+ Codec.Picture.Metadata: SourceGif :: SourceFormat
+ Codec.Picture.Metadata: SourceHDR :: SourceFormat
+ Codec.Picture.Metadata: SourceJpeg :: SourceFormat
+ Codec.Picture.Metadata: SourcePng :: SourceFormat
+ Codec.Picture.Metadata: SourceTGA :: SourceFormat
+ Codec.Picture.Metadata: SourceTiff :: SourceFormat
+ Codec.Picture.Metadata: Width :: Keys Word
+ Codec.Picture.Metadata: basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas
+ Codec.Picture.Metadata: data SourceFormat
+ Codec.Picture.Metadata: instance Eq SourceFormat
+ Codec.Picture.Metadata: instance NFData SourceFormat
+ Codec.Picture.Metadata: instance Show SourceFormat
+ Codec.Picture.Metadata: mkSizeMetadata :: Integral n => n -> n -> Metadatas
+ Codec.Picture.Metadata: simpleMetadata :: (Integral nSize, Integral nDpi) => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas
+ Codec.Picture.Tga: decodeTgaWithMetadata :: ByteString -> Either String (DynamicImage, Metadatas)
Files
- JuicyPixels.cabal +2/−2
- changelog +9/−1
- src/Codec/Picture.hs +6/−7
- src/Codec/Picture/Bitmap.hs +2/−1
- src/Codec/Picture/Gif.hs +844/−825
- src/Codec/Picture/HDR.hs +531/−521
- src/Codec/Picture/Jpg.hs +9/−3
- src/Codec/Picture/Metadata.hs +58/−1
- src/Codec/Picture/Png.hs +3/−1
- src/Codec/Picture/Png/Metadata.hs +3/−0
- src/Codec/Picture/Tga.hs +20/−10
- src/Codec/Picture/Tiff/Metadata.hs +3/−3
JuicyPixels.cabal view
@@ -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: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>>@@ -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)
changelog view
@@ -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
src/Codec/Picture.hs view
@@ -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)
src/Codec/Picture/Bitmap.hs view
@@ -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
src/Codec/Picture/Gif.hs view
@@ -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 - -{- - <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer - - <Logical Screen> ::= Logical Screen Descriptor [Global Color Table] - - <Data> ::= <Graphic Block> | - <Special-Purpose Block> - - <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block> - - <Graphic-Rendering Block> ::= <Table-Based Image> | - Plain Text Extension - - <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data - - <Special-Purpose Block> ::= 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++{-+ <GIF Data Stream> ::= Header <Logical Screen> <Data>* Trailer++ <Logical Screen> ::= Logical Screen Descriptor [Global Color Table]++ <Data> ::= <Graphic Block> |+ <Special-Purpose Block>++ <Graphic Block> ::= [Graphic Control Extension] <Graphic-Rendering Block>++ <Graphic-Rendering Block> ::= <Table-Based Image> |+ Plain Text Extension++ <Table-Based Image> ::= Image Descriptor [Local Color Table] Image Data++ <Special-Purpose Block> ::= 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+
src/Codec/Picture/HDR.hs view
@@ -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+
src/Codec/Picture/Jpg.hs view
@@ -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
src/Codec/Picture/Metadata.hs view
@@ -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+ ]
src/Codec/Picture/Png.hs view
@@ -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]
src/Codec/Picture/Png/Metadata.hs view
@@ -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)
src/Codec/Picture/Tga.hs view
@@ -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.
src/Codec/Picture/Tiff/Metadata.hs view
@@ -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