diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.3.1 +Version: 3.3.2 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.3.1 + Tag: v3.3.2 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -52,7 +52,7 @@ Codec.Picture.ColorQuant Ghc-options: -O3 -Wall - Build-depends: base >= 4.8 && < 5, + Build-depends: base >= 4.8 && < 6, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.3, binary >= 0.5 && < 0.9, @@ -61,11 +61,7 @@ vector >= 0.10 && < 0.13, primitive >= 0.4 && < 0.7, deepseq >= 1.1 && < 1.5, - containers >= 0.4.2 && < 0.6 - - if flag(Mmap) - Build-depends: mmap - CC-Options: "-DWITH_MMAP_BYTESTRING" + containers >= 0.4.2 && < 0.7 -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable, diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,6 +1,14 @@ Change log ========== +v3.3.2 October 2018 +------------------- + + * Fix: GHC-8.6 compilation fix (no upper bound on base) + * Fix: upper bound on containers (pull request phadej) + * Fix: palette validation for gifs (pull request omedan) + * New: More complete gif creation API (pull request omedan) + v3.3.1 August 2018 ------------------ diff --git a/docimages/pixelgraph.svg b/docimages/pixelgraph.svg --- a/docimages/pixelgraph.svg +++ b/docimages/pixelgraph.svg @@ -1,264 +1,264 @@ - - - - - - -pixelGraphic - - -PixelRGB8 - -PixelRGB8 - - -PixelRGBA8 - -PixelRGBA8 - - -PixelRGB8->PixelRGBA8 - - -promotePixel - - -PixelRGBF - -PixelRGBF - - -PixelRGB8->PixelRGBF - - -promotePixel - - -Pixel8 - -Pixel8 - - -PixelRGB8->Pixel8 - - -computeLuma - - -PixelCMYK8 - -PixelCMYK8 - - -PixelRGB8->PixelCMYK8 - - -convertPixel - - -PixelYCbCr8 - -PixelYCbCr8 - - -PixelRGB8->PixelYCbCr8 - - -convertPixel - - -PixelRGB16 - -PixelRGB16 - - -PixelRGBA16 - -PixelRGBA16 - - -PixelRGB16->PixelRGBA16 - - -promotePixel - - -Pixel16 - -Pixel16 - - -PixelRGB16->Pixel16 - - -computeLuma - - -PixelCMYK16 - -PixelCMYK16 - - -PixelRGB16->PixelCMYK16 - - -convertPixel - - -PixelRGBA16->PixelRGB16 - - -dropTransparency - - -PixelRGBA8->PixelRGB8 - - -dropTransparency - - -PixelRGBA8->Pixel8 - - -computeLuma - - -PixelF - -PixelF - - -PixelRGBF->PixelF - - -computeLuma - - -PixelYA16 - -PixelYA16 - - -PixelYA16->PixelRGBA16 - - -promotePixel - - -PixelYA16->Pixel16 - - -dropTransparency - - -PixelYA8 - -PixelYA8 - - -PixelYA8->PixelRGB8 - - -promotePixel - - -PixelYA8->PixelRGBA8 - - -promotePixel - - -PixelYA8->Pixel8 - - -dropTransparency - - -PixelYA8->Pixel8 - - -computeLuma - - -PixelF->PixelRGBF - - -promotePixel - - -Pixel16->PixelRGB16 - - -promotePixel - - -Pixel16->PixelRGBA16 - - -promotePixel - - -Pixel16->PixelYA16 - - -promotePixel - - -Pixel8->PixelRGB8 - - -promotePixel - - -Pixel8->PixelRGBA8 - - -promotePixel - - -Pixel8->PixelYA8 - - -promotePixel - - -Pixel8->PixelF - - -promotePixel - - -Pixel8->Pixel16 - - -promotePixel - - -PixelCMYK16->PixelRGB16 - - -convertPixel - - -PixelCMYK8->PixelRGB8 - - -convertPixel - - -PixelYCbCr8->PixelRGB8 - - -convertPixel - - -PixelYCbCr8->Pixel8 - - -computeLuma - - - + + + + + + +pixelGraphic + + +PixelRGB8 + +PixelRGB8 + + +PixelRGBA8 + +PixelRGBA8 + + +PixelRGB8->PixelRGBA8 + + +promotePixel + + +PixelRGBF + +PixelRGBF + + +PixelRGB8->PixelRGBF + + +promotePixel + + +Pixel8 + +Pixel8 + + +PixelRGB8->Pixel8 + + +computeLuma + + +PixelCMYK8 + +PixelCMYK8 + + +PixelRGB8->PixelCMYK8 + + +convertPixel + + +PixelYCbCr8 + +PixelYCbCr8 + + +PixelRGB8->PixelYCbCr8 + + +convertPixel + + +PixelRGB16 + +PixelRGB16 + + +PixelRGBA16 + +PixelRGBA16 + + +PixelRGB16->PixelRGBA16 + + +promotePixel + + +Pixel16 + +Pixel16 + + +PixelRGB16->Pixel16 + + +computeLuma + + +PixelCMYK16 + +PixelCMYK16 + + +PixelRGB16->PixelCMYK16 + + +convertPixel + + +PixelRGBA16->PixelRGB16 + + +dropTransparency + + +PixelRGBA8->PixelRGB8 + + +dropTransparency + + +PixelRGBA8->Pixel8 + + +computeLuma + + +PixelF + +PixelF + + +PixelRGBF->PixelF + + +computeLuma + + +PixelYA16 + +PixelYA16 + + +PixelYA16->PixelRGBA16 + + +promotePixel + + +PixelYA16->Pixel16 + + +dropTransparency + + +PixelYA8 + +PixelYA8 + + +PixelYA8->PixelRGB8 + + +promotePixel + + +PixelYA8->PixelRGBA8 + + +promotePixel + + +PixelYA8->Pixel8 + + +dropTransparency + + +PixelYA8->Pixel8 + + +computeLuma + + +PixelF->PixelRGBF + + +promotePixel + + +Pixel16->PixelRGB16 + + +promotePixel + + +Pixel16->PixelRGBA16 + + +promotePixel + + +Pixel16->PixelYA16 + + +promotePixel + + +Pixel8->PixelRGB8 + + +promotePixel + + +Pixel8->PixelRGBA8 + + +promotePixel + + +Pixel8->PixelYA8 + + +promotePixel + + +Pixel8->PixelF + + +promotePixel + + +Pixel8->Pixel16 + + +promotePixel + + +PixelCMYK16->PixelRGB16 + + +convertPixel + + +PixelCMYK8->PixelRGB8 + + +convertPixel + + +PixelYCbCr8->PixelRGB8 + + +convertPixel + + +PixelYCbCr8->Pixel8 + + +computeLuma + + + diff --git a/src/Codec/Picture/ConvGraph.hs b/src/Codec/Picture/ConvGraph.hs --- a/src/Codec/Picture/ConvGraph.hs +++ b/src/Codec/Picture/ConvGraph.hs @@ -1,10 +1,10 @@ --- $graph --- --- The following graph describe the differents way to convert between pixel types, --- --- * Nodes describe pixel type --- --- * Arrows describe functions --- --- <> --- +-- $graph +-- +-- The following graph describe the differents way to convert between pixel types, +-- +-- * Nodes describe pixel type +-- +-- * Arrows describe functions +-- +-- <> +-- diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -12,14 +12,19 @@ -- * Writing , GifDelay + , GifDisposalMethod( .. ) + , GifEncode( .. ) + , GifFrame( .. ) , GifLooping( .. ) , encodeGifImage , encodeGifImageWithPalette , encodeGifImages + , encodeComplexGifImage , writeGifImage , writeGifImageWithPalette , writeGifImages + , writeComplexGifImage , greyPalette ) where @@ -28,7 +33,7 @@ #endif import Control.Arrow( first ) -import Control.Monad( replicateM, replicateM_, unless ) +import Control.Monad( replicateM, replicateM_, unless, when ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift ) @@ -81,6 +86,42 @@ -- | The animation will repeat n times before stoping | LoopingRepeat Word16 + +-- | GIF image definition for encoding +data GifEncode = GifEncode + { -- | Screen width + geWidth :: Int + , -- | Screen height + geHeight :: Int + , -- | Global palette, optional + gePalette :: Maybe Palette + , -- | Background color index, optional. If given, a global palette is also required + geBackground :: Maybe Int + , -- | Looping behaviour + geLooping :: GifLooping + , -- | Image frames + geFrames :: [GifFrame] + } + +-- | An individual image frame in a GIF image +data GifFrame = GifFrame + { -- | Image X offset in GIF canvas + gfXOffset :: Int + , -- | Image Y offset in GIF canvas + gfYOffset :: Int + , -- | Image local palette, optional if a global palette is given + gfPalette :: Maybe Palette + , -- | Transparent color index, optional + gfTransparent :: Maybe Int + , -- | Frame transition delay, in 1/100ths of a second + gfDelay :: GifDelay + , -- | Frame disposal method + gfDisposal :: GifDisposalMethod + , -- | Image pixels + gfPixels :: Image Pixel8 + } + + {- ::= Header * Trailer @@ -227,14 +268,14 @@ putSlices str = putWord8 (fromIntegral $ B.length str) >> putByteString str -data DisposalMethod +data GifDisposalMethod = DisposalAny | DisposalDoNot | DisposalRestoreBackground | DisposalRestorePrevious | DisposalUnknown Word8 -disposalMethodOfCode :: Word8 -> DisposalMethod +disposalMethodOfCode :: Word8 -> GifDisposalMethod disposalMethodOfCode v = case v of 0 -> DisposalAny 1 -> DisposalDoNot @@ -242,7 +283,7 @@ 3 -> DisposalRestorePrevious n -> DisposalUnknown n -codeOfDisposalMethod :: DisposalMethod -> Word8 +codeOfDisposalMethod :: GifDisposalMethod -> Word8 codeOfDisposalMethod v = case v of DisposalAny -> 0 DisposalDoNot -> 1 @@ -251,7 +292,7 @@ DisposalUnknown n -> n data GraphicControlExtension = GraphicControlExtension - { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits + { gceDisposalMethod :: !GifDisposalMethod -- ^ Stored on 3 bits , gceUserInputFlag :: !Bool , gceTransparentFlag :: !Bool , gceDelay :: !Word16 @@ -432,7 +473,7 @@ data GifHeader = GifHeader { gifVersion :: GifVersion , gifScreenDescriptor :: LogicalScreenDescriptor - , gifGlobalMap :: !Palette + , gifGlobalMap :: Maybe Palette } instance Binary GifHeader where @@ -440,7 +481,9 @@ put $ gifVersion v let descr = gifScreenDescriptor v put descr - putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v + case gifGlobalMap v of + Just palette -> putPalette (fromIntegral $ colorTableSize descr) palette + Nothing -> return () get = do version <- get @@ -448,9 +491,9 @@ palette <- if hasGlobalMap screenDesc then - getPalette $ colorTableSize screenDesc + return <$> getPalette (colorTableSize screenDesc) else - return greyPalette + return Nothing return GifHeader { gifVersion = version @@ -579,7 +622,7 @@ | not (hasTransparency firstControl) = let backImage = generateImage (\_ _ -> backgroundColor) globalWidth globalHeight - thisPalette = paletteOf palette firstImage + thisPalette = paletteOf globalPalette firstImage baseImage = decodeImage firstImage initState = (thisPalette, firstControl, substituteColors thisPalette baseImage) @@ -598,7 +641,7 @@ generateImage (\_ _ -> transparentBackground) globalWidth globalHeight thisPalette :: Image PixelRGBA8 - thisPalette = paletteOf (promoteImage palette) firstImage + thisPalette = paletteOf (promoteImage globalPalette) firstImage transparentCode = transparentColorOf firstControl decoded = @@ -610,16 +653,17 @@ gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] - where + where globalWidth = fromIntegral $ screenWidth wholeDescriptor globalHeight = fromIntegral $ screenHeight wholeDescriptor + globalPalette = maybe greyPalette id palette transparentBackground = PixelRGBA8 r g b 0 where PixelRGB8 r g b = backgroundColor backgroundColor | hasGlobalMap wholeDescriptor = - pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + pixelAt globalPalette (fromIntegral $ backgroundIndex wholeDescriptor) 0 | otherwise = PixelRGB8 0 0 0 gifAnimationApplyer :: forall px. (ColorConvertible PixelRGB8 px) @@ -720,6 +764,67 @@ where toGrey x _ = PixelRGB8 ix ix ix where ix = fromIntegral x +checkImageSizes :: GifEncode -> Either String () +checkImageSizes GifEncode { geWidth = width, geHeight = height, geFrames = frames } + | not $ isInBounds width && isInBounds height = Left "Invalid screen bounds" + | not $ null outOfBounds = Left $ "GIF frames with invalid bounds: " ++ show (map snd outOfBounds) + | otherwise = Right () + where isInBounds dim = dim > 0 && dim <= 0xffff + outOfBounds = filter (not . isFrameInBounds . fst) $ zip frames [0 :: Int ..] + isFrameInBounds GifFrame { gfPixels = img } = isInBounds (imageWidth img) && isInBounds (imageHeight img) + +checkImagesInBounds :: GifEncode -> Either String () +checkImagesInBounds GifEncode { geWidth = width, geHeight = height, geFrames = frames } = + if null outOfBounds + then Right () + else Left $ "GIF frames out of screen bounds: " ++ show (map snd outOfBounds) + where outOfBounds = filter (not . isInBounds . fst) $ zip frames [0 :: Int ..] + isInBounds GifFrame { gfXOffset = xOff, gfYOffset = yOff, gfPixels = img } = + xOff >= 0 && yOff >= 0 && + xOff + imageWidth img <= width && yOff + imageHeight img <= height + +checkPaletteValidity :: GifEncode -> Either String () +checkPaletteValidity spec + | not $ isPaletteValid $ gePalette spec = Left "Invalid global palette size" + | not $ null invalidPalettes = Left $ "Invalid palette size in GIF frames: " ++ show (map snd invalidPalettes) + | otherwise = Right () + where invalidPalettes = filter (not . isPaletteValid . gfPalette . fst) $ zip (geFrames spec) [0 :: Int ..] + isPaletteValid Nothing = True + isPaletteValid (Just p) = let w = imageWidth p + h = imageHeight p + in h == 1 && w > 0 && w <= 256 + +checkIndexAbsentFromPalette :: GifEncode -> Either String () +checkIndexAbsentFromPalette GifEncode { gePalette = global, geFrames = frames } = + if null missingPalette + then Right () + else Left $ "GIF image frames with color indexes missing from palette: " ++ show (map snd missingPalette) + where missingPalette = filter (not . checkFrame . fst) $ zip frames [0 :: Int ..] + checkFrame frame = V.all (checkIndexInPalette global (gfPalette frame) . fromIntegral) $ + imageData $ gfPixels frame + +checkBackground :: GifEncode -> Either String () +checkBackground GifEncode { geBackground = Nothing } = Right () +checkBackground GifEncode { gePalette = global, geBackground = Just background } = + if checkIndexInPalette global Nothing background + then Right () + else Left "GIF background index absent from global palette" + +checkTransparencies :: GifEncode -> Either String () +checkTransparencies GifEncode { gePalette = global, geFrames = frames } = + if null missingTransparency + then Right () + else Left $ "GIF transparent index absent from palettes for frames: " ++ show (map snd missingTransparency) + where missingTransparency = filter (not . transparencyOK . fst) $ zip frames [0 :: Int ..] + transparencyOK GifFrame { gfTransparent = Nothing } = True + transparencyOK GifFrame { gfPalette = local, gfTransparent = Just transparent } = + checkIndexInPalette global local transparent + +checkIndexInPalette :: Maybe Palette -> Maybe Palette -> Int -> Bool +checkIndexInPalette Nothing Nothing _ = False +checkIndexInPalette _ (Just local) ix = ix < imageWidth local +checkIndexInPalette (Just global) _ ix = ix < imageWidth global + checkGifImageSizes :: [(a, b, Image px)] -> Bool checkGifImageSizes [] = False checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest @@ -729,95 +834,136 @@ 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 +computeColorTableSize :: Palette -> Int +computeColorTableSize Image { imageWidth = itemCount } = go 1 where go k | 2 ^ k >= itemCount = k | otherwise = go $ k + 1 --- | Encode a gif animation to a bytestring. +-- | Encode a complex gif to a bytestring. -- --- * Every image must have the same size +-- * There must be at least one image. -- +-- * The screen and every frame dimensions must be between 1 and 65535. +-- +-- * Every frame image must fit within the screen bounds. +-- -- * 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 +-- * There must be a global palette or every image must have a local palette. +-- +-- * The background color index must be present in the global palette. +-- +-- * Every frame's transparent color index, if set, must be present in the palette used by that frame. +-- +-- * Every color index used in an image must be present in the palette used by that frame. +-- +encodeComplexGifImage :: GifEncode -> Either String L.ByteString +encodeComplexGifImage spec = do + when (null $ geFrames spec) $ Left "No GIF frames" + checkImageSizes spec + checkImagesInBounds spec + checkPaletteValidity spec + checkBackground spec + checkTransparencies spec + checkIndexAbsentFromPalette spec + + Right $ encode allFile where - version = case imageList of + GifEncode { geWidth = width + , geHeight = height + , gePalette = globalPalette + , geBackground = background + , geLooping = looping + , geFrames = frames + } = spec + allFile = GifFile + { gifHeader = GifHeader + { gifVersion = version + , gifScreenDescriptor = logicalScreen + , gifGlobalMap = globalPalette + } + , gifImages = toSerialize + , gifLoopingBehaviour = looping + } + + version = case frames of [] -> GIF87a [_] -> GIF87a _:_:_ -> GIF89a - allFile = GifFile - { gifHeader = GifHeader - { gifVersion = version - , 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 - } + { screenWidth = fromIntegral width + , screenHeight = fromIntegral height + , backgroundIndex = maybe 0 fromIntegral background + , hasGlobalMap = maybe False (const True) globalPalette + , colorResolution = 8 + , isColorTableSorted = False + -- Imply a 8 bit global palette size if there's no explicit global palette. + , colorTableSize = maybe 8 (fromIntegral . computeColorTableSize) globalPalette + } - paletteEqual p = imageData firstPalette == imageData p + toSerialize = [(controlExtension delay transparent disposal, GifImage + { imgDescriptor = imageDescriptor left top localPalette img + , imgLocalPalette = localPalette + , imgLzwRootSize = fromIntegral lzwKeySize + , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img + }) + | GifFrame { gfXOffset = left + , gfYOffset = top + , gfPalette = localPalette + , gfTransparent = transparent + , gfDelay = delay + , gfDisposal = disposal + , gfPixels = img } <- frames + , let palette = case (globalPalette, localPalette) of + (_, Just local) -> local + (Just global, Nothing) -> global + (Nothing, Nothing) -> error "No palette for image" -- redundant, we guard for this + -- Some decoders (looking at you, GIMP) don't handle initial LZW key size of 1 correctly. + -- We'll waste some space for the sake of interoperability + , let lzwKeySize = max 2 $ computeColorTableSize palette + ] - controlExtension 0 = Nothing - controlExtension delay = Just GraphicControlExtension - { gceDisposalMethod = DisposalAny - , gceUserInputFlag = False - , gceTransparentFlag = False - , gceDelay = fromIntegral delay - , gceTransparentColorIndex = 0 - } + controlExtension 0 Nothing DisposalAny = Nothing + controlExtension delay transparent disposal = Just GraphicControlExtension + { gceDisposalMethod = disposal + , gceUserInputFlag = False + , gceTransparentFlag = maybe False (const True) transparent + , gceDelay = fromIntegral delay + , gceTransparentColorIndex = maybe 0 fromIntegral transparent + } - 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 left top localPalette img = ImageDescriptor + { gDescPixelsFromLeft = fromIntegral left + , gDescPixelsFromTop = fromIntegral top + , gDescImageWidth = fromIntegral $ imageWidth img + , gDescImageHeight = fromIntegral $ imageHeight img + , gDescHasLocalMap = maybe False (const True) localPalette + , gDescIsInterlaced = False + , gDescIsImgDescriptorSorted = False + , gDescLocalColorTableSize = maybe 0 (fromIntegral . computeColorTableSize) localPalette + } - 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 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" +encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = + encodeComplexGifImage $ GifEncode (imageWidth firstImage) (imageHeight firstImage) (Just firstPalette) Nothing looping frames + where + frames = [ GifFrame 0 0 localPalette Nothing delay DisposalAny image + | (palette, delay, image) <- imageList + , let localPalette = if paletteEqual palette then Nothing else Just palette ] + paletteEqual p = imageData firstPalette == imageData p + -- | Encode a greyscale image to a bytestring. encodeGifImage :: Image Pixel8 -> L.ByteString encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of @@ -856,3 +1002,5 @@ writeGifImageWithPalette file img palette = L.writeFile file <$> encodeGifImageWithPalette img palette +writeComplexGifImage :: FilePath -> GifEncode -> Either String (IO ()) +writeComplexGifImage file spec = L.writeFile file <$> encodeComplexGifImage spec diff --git a/src/Codec/Picture/Gif/LZW.hs b/src/Codec/Picture/Gif/LZW.hs --- a/src/Codec/Picture/Gif/LZW.hs +++ b/src/Codec/Picture/Gif/LZW.hs @@ -1,194 +1,194 @@ -{-# LANGUAGE CPP #-} -module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -#endif - -import Data.Word( Word8 ) -import Control.Monad( when, unless ) - -import Data.Bits( (.&.) ) - -import Control.Monad.ST( ST ) -import Control.Monad.Trans.Class( MonadTrans, lift ) - -import Foreign.Storable ( Storable ) - -import qualified Data.ByteString as B -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.BitWriter - -{-# INLINE (.!!!.) #-} -(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a -(.!!!.) = M.unsafeRead - {-M.read-} - -{-# INLINE (..!!!..) #-} -(..!!!..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> t (ST s) a -(..!!!..) v idx = lift $ v .!!!. idx - -{-# INLINE (.<-.) #-} -(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () -(.<-.) = M.unsafeWrite - {-M.write-} - -{-# INLINE (..<-..) #-} -(..<-..) :: (MonadTrans t, Storable a) - => M.STVector s a -> Int -> a -> t (ST s) () -(..<-..) v idx = lift . (v .<-. idx) - - -duplicateData :: (MonadTrans t, Storable a) - => M.STVector s a -> M.STVector s a - -> Int -> Int -> Int -> t (ST s) () -duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex - where endIndex = sourceIndex + size - aux i _ | i == endIndex = return () - aux i j = do - src .!!!. i >>= (dest .<-. j) - aux (i + 1) (j + 1) - -rangeSetter :: (Storable a, Num a) - => Int -> M.STVector s a - -> ST s (M.STVector s a) -rangeSetter count vec = aux 0 - where aux n | n == count = return vec - aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) - -decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -decodeLzw str maxBitKey initialKey outVec = do - setDecodedString str - lzw GifVariant maxBitKey initialKey 0 outVec - -isOldTiffLZW :: B.ByteString -> Bool -isOldTiffLZW str = firstByte == 0 && secondByte == 1 - where firstByte = str `B.index` 0 - secondByte = (str `B.index` 1) .&. 1 - -decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int - -> BoolReader s() -decodeLzwTiff str outVec initialWriteIdx = do - if isOldTiffLZW str then - setDecodedString str - else - setDecodedStringMSB str - let variant | isOldTiffLZW str = OldTiffVariant - | otherwise = TiffVariant - lzw variant 12 9 initialWriteIdx outVec - -data TiffVariant = - GifVariant - | TiffVariant - | OldTiffVariant - deriving Eq - --- | Gif image constraint from spec-gif89a, code size max : 12 bits. -lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 - -> BoolReader s () -lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do - -- Allocate buffer of maximum size. - lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray - lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray - lzwSizeTable <- lift $ M.replicate tableEntryCount 0 - lift $ lzwSizeTable `M.set` 1 - - let firstVal code = do - dataOffset <- lzwOffsetTable ..!!!.. code - lzwData ..!!!.. dataOffset - - writeString at code = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (at + dataSize <= maxWrite) $ - duplicateData lzwData outVec dataOffset dataSize at - - return dataSize - - addString pos at code val = do - dataOffset <- lzwOffsetTable ..!!!.. code - dataSize <- lzwSizeTable ..!!!.. code - - when (pos < tableEntryCount) $ do - (lzwOffsetTable ..<-.. pos) at - (lzwSizeTable ..<-.. pos) $ dataSize + 1 - - when (at + dataSize + 1 <= maxDataSize) $ do - duplicateData lzwData lzwData dataOffset dataSize at - (lzwData ..<-.. (at + dataSize)) val - - return $ dataSize + 1 - - maxWrite = M.length outVec - loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code - | outWriteIdx >= maxWrite = return () - | code == endOfInfo = return () - | code == clearCode = do - toOutput <- getNextCode startCodeSize - unless (toOutput == endOfInfo) $ do - dataSize <- writeString outWriteIdx toOutput - getNextCode startCodeSize >>= - loop (outWriteIdx + dataSize) - firstFreeIndex firstFreeIndex startCodeSize toOutput - - | otherwise = do - (written, dicAdd) <- - if code >= writeIdx then do - c <- firstVal oldCode - wroteSize <- writeString outWriteIdx oldCode - (outVec ..<-.. (outWriteIdx + wroteSize)) c - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize + 1, addedSize) - else do - wroteSize <- writeString outWriteIdx code - c <- firstVal code - addedSize <- addString writeIdx dicWriteIdx oldCode c - return (wroteSize, addedSize) - - let new_code_size = updateCodeSize codeSize $ writeIdx + 1 - getNextCode new_code_size >>= - loop (outWriteIdx + written) - (writeIdx + 1) - (dicWriteIdx + dicAdd) - new_code_size - code - - getNextCode startCodeSize >>= - loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 - - where tableEntryCount = 2 ^ min 12 nMaxBitKeySize - maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 - - isNewTiff = variant == TiffVariant - (switchOffset, isTiffVariant) = case variant of - GifVariant -> (0, False) - TiffVariant -> (1, True) - OldTiffVariant -> (0, True) - - initialElementCount = 2 ^ initialKeySize :: Int - clearCode | isTiffVariant = 256 - | otherwise = initialElementCount - - endOfInfo | isTiffVariant = 257 - | otherwise = clearCode + 1 - - startCodeSize - | isTiffVariant = initialKeySize - | otherwise = initialKeySize + 1 - - firstFreeIndex = endOfInfo + 1 - - resetArray a = lift $ rangeSetter initialElementCount a - - updateCodeSize codeSize writeIdx - | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 - | otherwise = codeSize - - getNextCode s - | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s - | otherwise = fromIntegral <$> getNextBitsLSBFirst s - +{-# LANGUAGE CPP #-} +module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Word( Word8 ) +import Control.Monad( when, unless ) + +import Data.Bits( (.&.) ) + +import Control.Monad.ST( ST ) +import Control.Monad.Trans.Class( MonadTrans, lift ) + +import Foreign.Storable ( Storable ) + +import qualified Data.ByteString as B +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.BitWriter + +{-# INLINE (.!!!.) #-} +(.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a +(.!!!.) = M.unsafeRead + {-M.read-} + +{-# INLINE (..!!!..) #-} +(..!!!..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> t (ST s) a +(..!!!..) v idx = lift $ v .!!!. idx + +{-# INLINE (.<-.) #-} +(.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () +(.<-.) = M.unsafeWrite + {-M.write-} + +{-# INLINE (..<-..) #-} +(..<-..) :: (MonadTrans t, Storable a) + => M.STVector s a -> Int -> a -> t (ST s) () +(..<-..) v idx = lift . (v .<-. idx) + + +duplicateData :: (MonadTrans t, Storable a) + => M.STVector s a -> M.STVector s a + -> Int -> Int -> Int -> t (ST s) () +duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex + where endIndex = sourceIndex + size + aux i _ | i == endIndex = return () + aux i j = do + src .!!!. i >>= (dest .<-. j) + aux (i + 1) (j + 1) + +rangeSetter :: (Storable a, Num a) + => Int -> M.STVector s a + -> ST s (M.STVector s a) +rangeSetter count vec = aux 0 + where aux n | n == count = return vec + aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) + +decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +decodeLzw str maxBitKey initialKey outVec = do + setDecodedString str + lzw GifVariant maxBitKey initialKey 0 outVec + +isOldTiffLZW :: B.ByteString -> Bool +isOldTiffLZW str = firstByte == 0 && secondByte == 1 + where firstByte = str `B.index` 0 + secondByte = (str `B.index` 1) .&. 1 + +decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int + -> BoolReader s() +decodeLzwTiff str outVec initialWriteIdx = do + if isOldTiffLZW str then + setDecodedString str + else + setDecodedStringMSB str + let variant | isOldTiffLZW str = OldTiffVariant + | otherwise = TiffVariant + lzw variant 12 9 initialWriteIdx outVec + +data TiffVariant = + GifVariant + | TiffVariant + | OldTiffVariant + deriving Eq + +-- | Gif image constraint from spec-gif89a, code size max : 12 bits. +lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 + -> BoolReader s () +lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do + -- Allocate buffer of maximum size. + lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray + lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray + lzwSizeTable <- lift $ M.replicate tableEntryCount 0 + lift $ lzwSizeTable `M.set` 1 + + let firstVal code = do + dataOffset <- lzwOffsetTable ..!!!.. code + lzwData ..!!!.. dataOffset + + writeString at code = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (at + dataSize <= maxWrite) $ + duplicateData lzwData outVec dataOffset dataSize at + + return dataSize + + addString pos at code val = do + dataOffset <- lzwOffsetTable ..!!!.. code + dataSize <- lzwSizeTable ..!!!.. code + + when (pos < tableEntryCount) $ do + (lzwOffsetTable ..<-.. pos) at + (lzwSizeTable ..<-.. pos) $ dataSize + 1 + + when (at + dataSize + 1 <= maxDataSize) $ do + duplicateData lzwData lzwData dataOffset dataSize at + (lzwData ..<-.. (at + dataSize)) val + + return $ dataSize + 1 + + maxWrite = M.length outVec + loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code + | outWriteIdx >= maxWrite = return () + | code == endOfInfo = return () + | code == clearCode = do + toOutput <- getNextCode startCodeSize + unless (toOutput == endOfInfo) $ do + dataSize <- writeString outWriteIdx toOutput + getNextCode startCodeSize >>= + loop (outWriteIdx + dataSize) + firstFreeIndex firstFreeIndex startCodeSize toOutput + + | otherwise = do + (written, dicAdd) <- + if code >= writeIdx then do + c <- firstVal oldCode + wroteSize <- writeString outWriteIdx oldCode + (outVec ..<-.. (outWriteIdx + wroteSize)) c + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize + 1, addedSize) + else do + wroteSize <- writeString outWriteIdx code + c <- firstVal code + addedSize <- addString writeIdx dicWriteIdx oldCode c + return (wroteSize, addedSize) + + let new_code_size = updateCodeSize codeSize $ writeIdx + 1 + getNextCode new_code_size >>= + loop (outWriteIdx + written) + (writeIdx + 1) + (dicWriteIdx + dicAdd) + new_code_size + code + + getNextCode startCodeSize >>= + loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 + + where tableEntryCount = 2 ^ min 12 nMaxBitKeySize + maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 + + isNewTiff = variant == TiffVariant + (switchOffset, isTiffVariant) = case variant of + GifVariant -> (0, False) + TiffVariant -> (1, True) + OldTiffVariant -> (0, True) + + initialElementCount = 2 ^ initialKeySize :: Int + clearCode | isTiffVariant = 256 + | otherwise = initialElementCount + + endOfInfo | isTiffVariant = 257 + | otherwise = clearCode + 1 + + startCodeSize + | isTiffVariant = initialKeySize + | otherwise = initialKeySize + 1 + + firstFreeIndex = endOfInfo + 1 + + resetArray a = lift $ rangeSetter initialElementCount a + + updateCodeSize codeSize writeIdx + | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 + | otherwise = codeSize + + getNextCode s + | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s + | otherwise = fromIntegral <$> getNextBitsLSBFirst s + diff --git a/src/Codec/Picture/HDR.hs b/src/Codec/Picture/HDR.hs --- a/src/Codec/Picture/HDR.hs +++ b/src/Codec/Picture/HDR.hs @@ -1,530 +1,530 @@ -{-# 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 image can be: --- --- * 'ImageRGBF' --- -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 - +{-# 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 image can be: +-- +-- * 'ImageRGBF' +-- +decodeHDR :: B.ByteString -> Either String DynamicImage +decodeHDR = fmap fst . decodeHDRWithMetadata + +-- | Equivalent to decodeHDR but with aditional metadatas. +decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) +decodeHDRWithMetadata str = runST $ runExceptT $ + case runGet decodeHeader $ L.fromChunks [str] of + Left err -> throwE err + Right rez -> + let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $ radianceHeight rez) in + (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) + +getChar8 :: Get Char +getChar8 = chr . fromIntegral <$> getWord8 + +isSign :: Char -> Bool +isSign c = c == '+' || c == '-' + +isAxisLetter :: Char -> Bool +isAxisLetter c = c == 'X' || c == 'Y' + +decodeNum :: Get Int +decodeNum = do + sign <- getChar8 + letter <- getChar8 + space <- getChar8 + + unless (isSign sign && isAxisLetter letter && space == ' ') + (fail "Invalid radiance size declaration") + + let numDec acc c | isDigit c = + getChar8 >>= numDec (acc * 10 + ord c - ord '0') + numDec acc _ + | sign == '-' = pure $ negate acc + | otherwise = pure acc + + getChar8 >>= numDec 0 + +copyPrevColor :: M.STVector s Word8 -> Int -> ST s () +copyPrevColor scanLine idx = do + r <- scanLine `M.unsafeRead` (idx - 4) + g <- scanLine `M.unsafeRead` (idx - 3) + b <- scanLine `M.unsafeRead` (idx - 2) + e <- scanLine `M.unsafeRead` (idx - 1) + + (scanLine `M.unsafeWrite` (idx + 0)) r + (scanLine `M.unsafeWrite` (idx + 1)) g + (scanLine `M.unsafeWrite` (idx + 2)) b + (scanLine `M.unsafeWrite` (idx + 3)) e + +oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 + where maxOutput = M.length scanLine + maxInput = fromIntegral $ L.length inputData + + inner readIdx writeIdx _ + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx shift = do + let color@(RGBE r g b e) = unpackColor inputData readIdx + isRun = r == 1 && g == 1 && b == 1 + + if not isRun + then do + lift $ storeColor scanLine writeIdx color + inner (readIdx + 4) (writeIdx + 4) 0 + + else do + let count = fromIntegral e .<<. shift + lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) + inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) + +newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 + -> HDRReader s Int +newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] + where dataAt idx + | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" + | otherwise = pure $ L.index inputData (fromIntegral idx) + + maxOutput = M.length scanline + maxInput = fromIntegral $ L.length inputData + stride = 4 + + + strideSet count destIndex _ | endIndex > maxOutput + stride = + throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" + where endIndex = destIndex + count * stride + strideSet count destIndex val = aux destIndex count + where aux i 0 = pure i + aux i c = do + lift $ (scanline .<-. i) val + aux (i + stride) (c - 1) + + + strideCopy _ count destIndex + | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" + where writeEndBound = destIndex + count * stride + strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count + where aux _ j 0 = pure j + aux i j c = do + val <- dataAt i + lift $ (scanline .<-. j) val + aux (i + 1) (j + stride) (c - 1) + + inner readIdx writeIdx + | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx + inner readIdx writeIdx = do + code <- dataAt readIdx + if code > 128 + then do + let repeatCount = fromIntegral code .&. 0x7F + newVal <- dataAt $ readIdx + 1 + endIndex <- strideSet repeatCount writeIdx newVal + inner (readIdx + 2) endIndex + + else do + let iCode = fromIntegral code + endIndex <- strideCopy (readIdx + 1) iCode writeIdx + inner (readIdx + iCode + 1) endIndex + +instance Binary RadianceHeader where + get = decodeHeader + put hdr = do + putByteString radianceFileSignature + putByteString $ BC.pack "FORMAT=" + put $ radianceFormat hdr + let sizeString = + BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) + ++ " +X " ++ show (radianceWidth hdr) ++ "\n" + putByteString sizeString + putLazyByteString $ radianceData hdr + + +decodeHeader :: Get RadianceHeader +decodeHeader = do + sig <- getByteString $ B.length radianceFileSignature + when (sig /= radianceFileSignature) + (fail "Invalid radiance file signature") + + infos <- decodeInfos + let formatKey = BC.pack "FORMAT" + case partition (\(k,_) -> k /= formatKey) infos of + (_, []) -> fail "No radiance format specified" + (info, [(_, formatString)]) -> + case runGet get $ L.fromChunks [formatString] of + Left err -> fail err + Right format -> do + (n1, n2, b) <- (,,) <$> decodeNum + <*> decodeNum + <*> getRemainingBytes + return . RadianceHeader info format n1 n2 $ L.fromChunks [b] + + _ -> fail "Multiple radiance format specified" + +toFloat :: RGBE -> PixelRGBF +toFloat (RGBE r g b e) = PixelRGBF rf gf bf + where f = encodeFloat 1 $ fromIntegral e - (128 + 8) + rf = (fromIntegral r + 0.0) * f + gf = (fromIntegral g + 0.0) * f + bf = (fromIntegral b + 0.0) * f + +encodeScanlineColor :: M.STVector s Word8 + -> M.STVector s Word8 + -> Int + -> ST s Int +encodeScanlineColor vec outVec outIdx = do + val <- vec `M.unsafeRead` 0 + runLength 1 0 val 1 outIdx + where maxIndex = M.length vec + + pushRun len val at = do + (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 + (outVec `M.unsafeWrite` (at + 1)) val + return $ at + 2 + + pushData start len at = do + (outVec `M.unsafeWrite` at) $ fromIntegral len + let first = start - len + end = start - 1 + offset = at - first + 1 + forM_ [first .. end] $ \i -> do + v <- vec `M.unsafeRead` i + (outVec `M.unsafeWrite` (offset + i)) v + + return $ at + len + 1 + + -- End of scanline, empty the thing + runLength run cpy prev idx at | idx >= maxIndex = + case (run, cpy) of + (0, 0) -> pure at + (0, n) -> pushData idx n at + (n, 0) -> pushRun n prev at + (_, _) -> error "HDR - Run length algorithm is wrong" + + -- full runlength, we must write the packet + runLength r@127 _ prev idx at = do + val <- vec `M.unsafeRead` idx + pushRun r prev at >>= + runLength 1 0 val (idx + 1) + + -- full copy, we must write the packet + runLength _ c@127 _ idx at = do + val <- vec `M.unsafeRead` idx + pushData idx c at >>= + runLength 1 0 val (idx + 1) + + runLength n 0 prev idx at = do + val <- vec `M.unsafeRead` idx + case val == prev of + True -> runLength (n + 1) 0 prev (idx + 1) at + False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at + False -> + pushRun n prev at >>= + runLength 1 0 val (idx + 1) + + runLength 0 n prev idx at = do + val <- vec `M.unsafeRead` idx + if val /= prev + then runLength 0 (n + 1) val (idx + 1) at + else + pushData (idx - 1) (n - 1) at >>= + runLength (2 :: Int) 0 val (idx + 1) + + runLength _ _ _ _ _ = + error "HDR RLE inconsistent state" + +-- | Write an High dynamic range image into a radiance +-- image file on disk. +writeHDR :: FilePath -> Image PixelRGBF -> IO () +writeHDR filename img = L.writeFile filename $ encodeHDR img + +-- | Write a RLE encoded High dynamic range image into a radiance +-- image file on disk. +writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO () +writeRLENewStyleHDR filename img = + L.writeFile filename $ encodeRLENewStyleHDR img + +-- | Encode an High dynamic range image into a radiance image +-- file format. +-- Alias for encodeRawHDR +encodeHDR :: Image PixelRGBF -> L.ByteString +encodeHDR = encodeRawHDR + +-- | Encode an High dynamic range image into a radiance image +-- file format. without compression +encodeRawHDR :: Image PixelRGBF -> L.ByteString +encodeRawHDR pic = encode descriptor + where + newImage = pixelMap rgbeInRgba pic + -- we are cheating to death here, the layout we want + -- correspond to the layout of pixelRGBA8, so we + -- convert + rgbeInRgba pixel = PixelRGBA8 r g b e + where RGBE r g b e = toRGBE pixel + + descriptor = RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = imageHeight pic + , radianceWidth = imageWidth pic + , radianceData = L.fromChunks [toByteString $ imageData newImage] + } + + +-- | Encode an High dynamic range image into a radiance image +-- file format using a light RLE compression. Some problems +-- seem to arise with some image viewer. +encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString +encodeRLENewStyleHDR pic = encode $ runST $ do + let w = imageWidth pic + h = imageHeight pic + + scanLineR <- M.new w :: ST s (M.STVector s Word8) + scanLineG <- M.new w + scanLineB <- M.new w + scanLineE <- M.new w + + encoded <- + forM [0 .. h - 1] $ \line -> do + buff <- M.new $ w * 4 + w `div` 127 + 2 + let columner col | col >= w = return () + columner col = do + let RGBE r g b e = toRGBE $ pixelAt pic col line + (scanLineR `M.unsafeWrite` col) r + (scanLineG `M.unsafeWrite` col) g + (scanLineB `M.unsafeWrite` col) b + (scanLineE `M.unsafeWrite` col) e + + columner (col + 1) + + columner 0 + + (buff `M.unsafeWrite` 0) 2 + (buff `M.unsafeWrite` 1) 2 + (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) + (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) + + i1 <- encodeScanlineColor scanLineR buff 4 + i2 <- encodeScanlineColor scanLineG buff i1 + i3 <- encodeScanlineColor scanLineB buff i2 + endIndex <- encodeScanlineColor scanLineE buff i3 + + (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff + + pure RadianceHeader + { radianceInfos = [] + , radianceFormat = FormatRGBE + , radianceHeight = h + , radianceWidth = w + , radianceData = L.fromChunks encoded + } + + +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) +decodeRadiancePicture hdr = do + let width = abs $ radianceWidth hdr + height = abs $ radianceHeight hdr + packedData = radianceData hdr + + scanLine <- lift $ M.new $ width * 4 + resultBuffer <- lift $ M.new $ width * height * 3 + + let scanLineImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = 1 + , mutableImageData = scanLine + } + + finalImage = MutableImage + { mutableImageWidth = width + , mutableImageHeight = height + , mutableImageData = resultBuffer + } + + let scanLineExtractor readIdx line = do + let color = unpackColor packedData readIdx + inner | isNewRunLengthMarker color = do + let calcSize = checkLineLength color + when (calcSize /= width) + (throwE "Invalid sanline size") + pure $ \idx -> newStyleRLE packedData (idx + 4) + | otherwise = pure $ oldStyleRLE packedData + f <- inner + newRead <- f readIdx scanLine + forM_ [0 .. width - 1] $ \i -> do + -- mokay, it's a hack, but I don't want to define a + -- pixel instance of RGBE... + PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 + lift $ writePixel finalImage i line . toFloat $ RGBE r g b e + + return newRead + + foldM_ scanLineExtractor 0 [0 .. height - 1] + + return finalImage + diff --git a/src/Codec/Picture/InternalHelper.hs b/src/Codec/Picture/InternalHelper.hs --- a/src/Codec/Picture/InternalHelper.hs +++ b/src/Codec/Picture/InternalHelper.hs @@ -1,51 +1,51 @@ -{-# LANGUAGE CPP #-} -module Codec.Picture.InternalHelper ( runGet - , runGetStrict - , decode - , getRemainingBytes - , getRemainingLazyBytes ) where - -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Binary( Binary( get ) ) -import Data.Binary.Get( Get - , getRemainingLazyByteString - ) -import qualified Data.Binary.Get as G - -#if MIN_VERSION_binary(0,6,4) -#else -import Control.Applicative( (<$>) ) -import qualified Control.Exception as E --- I feel so dirty. :( -import System.IO.Unsafe( unsafePerformIO ) -#endif - -decode :: (Binary a) => B.ByteString -> Either String a -decode = runGetStrict get - -runGet :: Get a -> L.ByteString -> Either String a -#if MIN_VERSION_binary(0,6,4) -runGet act = unpack . G.runGetOrFail act - where unpack (Left (_, _, str)) = Left str - unpack (Right (_, _, element)) = Right element -#else -runGet act str = unsafePerformIO $ E.catch - (Right <$> E.evaluate (G.runGet act str)) - (\msg -> return . Left $ show (msg :: E.SomeException)) -#endif - -runGetStrict :: Get a -> B.ByteString -> Either String a -runGetStrict act buffer = runGet act $ L.fromChunks [buffer] - -getRemainingBytes :: Get B.ByteString -getRemainingBytes = do - rest <- getRemainingLazyByteString - return $ case L.toChunks rest of - [] -> B.empty - [a] -> a - lst -> B.concat lst - -getRemainingLazyBytes :: Get L.ByteString -getRemainingLazyBytes = getRemainingLazyByteString - +{-# LANGUAGE CPP #-} +module Codec.Picture.InternalHelper ( runGet + , runGetStrict + , decode + , getRemainingBytes + , getRemainingLazyBytes ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Binary( Binary( get ) ) +import Data.Binary.Get( Get + , getRemainingLazyByteString + ) +import qualified Data.Binary.Get as G + +#if MIN_VERSION_binary(0,6,4) +#else +import Control.Applicative( (<$>) ) +import qualified Control.Exception as E +-- I feel so dirty. :( +import System.IO.Unsafe( unsafePerformIO ) +#endif + +decode :: (Binary a) => B.ByteString -> Either String a +decode = runGetStrict get + +runGet :: Get a -> L.ByteString -> Either String a +#if MIN_VERSION_binary(0,6,4) +runGet act = unpack . G.runGetOrFail act + where unpack (Left (_, _, str)) = Left str + unpack (Right (_, _, element)) = Right element +#else +runGet act str = unsafePerformIO $ E.catch + (Right <$> E.evaluate (G.runGet act str)) + (\msg -> return . Left $ show (msg :: E.SomeException)) +#endif + +runGetStrict :: Get a -> B.ByteString -> Either String a +runGetStrict act buffer = runGet act $ L.fromChunks [buffer] + +getRemainingBytes :: Get B.ByteString +getRemainingBytes = do + rest <- getRemainingLazyByteString + return $ case L.toChunks rest of + [] -> B.empty + [a] -> a + lst -> B.concat lst + +getRemainingLazyBytes :: Get L.ByteString +getRemainingLazyBytes = getRemainingLazyByteString + diff --git a/src/Codec/Picture/Jpg/FastDct.hs b/src/Codec/Picture/Jpg/FastDct.hs --- a/src/Codec/Picture/Jpg/FastDct.hs +++ b/src/Codec/Picture/Jpg/FastDct.hs @@ -1,218 +1,218 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies #-} -module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>) ) -#endif - -import Data.Int( Int16, Int32 ) -import Data.Bits( unsafeShiftR, unsafeShiftL ) -import Control.Monad.ST( ST ) - -import qualified Data.Vector.Storable.Mutable as M - -import Codec.Picture.Jpg.Types -import Control.Monad( forM, forM_ ) - --- | Reference implementation of the DCT, directly implementing the formula --- of ITU-81. It's slow as hell, perform to many operations, but is accurate --- and a good reference point. -referenceDct :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int32) -referenceDct workData block = do - forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] $ \(u,v) -> do - val <- at (u,v) - (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val - - return workData - where -- at :: (Int, Int) -> ST s Float - at (u,v) = do - toSum <- - forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do - sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x)) - return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) - * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16) - return $ sum toSum - - c 0 = 1 / sqrt 2 - c _ = 1 - -pASS1_BITS, cONST_BITS :: Int -cONST_BITS = 13 -pASS1_BITS = 2 - - -fIX_0_298631336, fIX_0_390180644, fIX_0_541196100, - fIX_0_765366865, fIX_0_899976223, fIX_1_175875602, - fIX_1_501321110, fIX_1_847759065, fIX_1_961570560, - fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32 -fIX_0_298631336 = 2446 -- FIX(0.298631336) */ -fIX_0_390180644 = 3196 -- FIX(0.390180644) */ -fIX_0_541196100 = 4433 -- FIX(0.541196100) */ -fIX_0_765366865 = 6270 -- FIX(0.765366865) */ -fIX_0_899976223 = 7373 -- FIX(0.899976223) */ -fIX_1_175875602 = 9633 -- FIX(1.175875602) */ -fIX_1_501321110 = 12299 -- FIX(1.501321110) */ -fIX_1_847759065 = 15137 -- FIX(1.847759065) */ -fIX_1_961570560 = 16069 -- FIX(1.961570560) */ -fIX_2_053119869 = 16819 -- FIX(2.053119869) */ -fIX_2_562915447 = 20995 -- FIX(2.562915447) */ -fIX_3_072711026 = 25172 -- FIX(3.072711026) */ - -cENTERJSAMPLE :: Int32 -cENTERJSAMPLE = 128 - --- | Fast DCT extracted from libjpeg -fastDctLibJpeg :: MutableMacroBlock s Int32 - -> MutableMacroBlock s Int16 - -> ST s (MutableMacroBlock s Int32) -fastDctLibJpeg workData sample_block = do - firstPass workData 0 - secondPass workData 7 - {-_ <- mutate (\_ a -> a `quot` 8) workData-} - return workData - where -- Pass 1: process rows. - -- Note results are scaled up by sqrt(8) compared to a true DCT; - -- furthermore, we scale the results by 2**PASS1_BITS. - firstPass _ i | i == dctBlockSize = return () - firstPass dataBlock i = do - let baseIdx = i * dctBlockSize - readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) - mult = (*) - writeAt idx = dataBlock `M.unsafeWrite` (baseIdx + idx) - writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) - (n `unsafeShiftR` (cONST_BITS - pASS1_BITS)) - - blk0 <- readAt 0 - blk1 <- readAt 1 - blk2 <- readAt 2 - blk3 <- readAt 3 - blk4 <- readAt 4 - blk5 <- readAt 5 - blk6 <- readAt 6 - blk7 <- readAt 7 - - let tmp0 = blk0 + blk7 - tmp1 = blk1 + blk6 - tmp2 = blk2 + blk5 - tmp3 = blk3 + blk4 - - tmp10 = tmp0 + tmp3 - tmp12 = tmp0 - tmp3 - tmp11 = tmp1 + tmp2 - tmp13 = tmp1 - tmp2 - - tmp0' = blk0 - blk7 - tmp1' = blk1 - blk6 - tmp2' = blk2 - blk5 - tmp3' = blk3 - blk4 - - -- Stage 4 and output - writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1)) - - writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 - writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 - - let tmp10' = tmp0' + tmp3' - tmp11' = tmp1' + tmp2' - tmp12' = tmp0' + tmp2' - tmp13' = tmp1' + tmp3' - z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */ - -- Add fudge factor here for final descale. */ - + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1)) - tmp0'' = mult tmp0' fIX_1_501321110 - tmp1'' = mult tmp1' fIX_3_072711026 - tmp2'' = mult tmp2' fIX_2_053119869 - tmp3'' = mult tmp3' fIX_0_298631336 - - tmp10'' = mult tmp10' (- fIX_0_899976223) - tmp11'' = mult tmp11' (- fIX_2_562915447) - tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' - tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' - - writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' - writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' - writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' - writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' - - firstPass dataBlock $ i + 1 - - -- Pass 2: process columns. - -- We remove the PASS1_BITS scaling, but leave the results scaled up - -- by an overall factor of 8. - secondPass :: M.STVector s Int32 -> Int -> ST s () - secondPass _ (-1) = return () - secondPass block i = do - let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize) - mult = (*) - writeAt idx = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i)) - writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3) - blk0 <- readAt 0 - blk1 <- readAt 1 - blk2 <- readAt 2 - blk3 <- readAt 3 - blk4 <- readAt 4 - blk5 <- readAt 5 - blk6 <- readAt 6 - blk7 <- readAt 7 - - let tmp0 = blk0 + blk7 - tmp1 = blk1 + blk6 - tmp2 = blk2 + blk5 - tmp3 = blk3 + blk4 - - -- Add fudge factor here for final descale. */ - tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1)) - tmp12 = tmp0 - tmp3 - tmp11 = tmp1 + tmp2 - tmp13 = tmp1 - tmp2 - - tmp0' = blk0 - blk7 - tmp1' = blk1 - blk6 - tmp2' = blk2 - blk5 - tmp3' = blk3 - blk4 - - writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3) - writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) - - let z1 = mult (tmp12 + tmp13) fIX_0_541196100 - + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1)) - - writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 - writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 - - let tmp10' = tmp0' + tmp3' - tmp11' = tmp1' + tmp2' - tmp12' = tmp0' + tmp2' - tmp13' = tmp1' + tmp3' - - z1' = mult (tmp12' + tmp13') fIX_1_175875602 - -- Add fudge factor here for final descale. */ - + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1); - - tmp0'' = mult tmp0' fIX_1_501321110 - tmp1'' = mult tmp1' fIX_3_072711026 - tmp2'' = mult tmp2' fIX_2_053119869 - tmp3'' = mult tmp3' fIX_0_298631336 - tmp10'' = mult tmp10' (- fIX_0_899976223) - tmp11'' = mult tmp11' (- fIX_2_562915447) - tmp12'' = mult tmp12' (- fIX_0_390180644) - + z1' - tmp13'' = mult tmp13' (- fIX_1_961570560) - + z1' - writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' - writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' - writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' - writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' - - secondPass block (i - 1) - -{-# ANN module "HLint: ignore Use camelCase" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} - +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>) ) +#endif + +import Data.Int( Int16, Int32 ) +import Data.Bits( unsafeShiftR, unsafeShiftL ) +import Control.Monad.ST( ST ) + +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Jpg.Types +import Control.Monad( forM, forM_ ) + +-- | Reference implementation of the DCT, directly implementing the formula +-- of ITU-81. It's slow as hell, perform to many operations, but is accurate +-- and a good reference point. +referenceDct :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int32) +referenceDct workData block = do + forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] $ \(u,v) -> do + val <- at (u,v) + (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val + + return workData + where -- at :: (Int, Int) -> ST s Float + at (u,v) = do + toSum <- + forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do + sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x)) + return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) + * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16) + return $ sum toSum + + c 0 = 1 / sqrt 2 + c _ = 1 + +pASS1_BITS, cONST_BITS :: Int +cONST_BITS = 13 +pASS1_BITS = 2 + + +fIX_0_298631336, fIX_0_390180644, fIX_0_541196100, + fIX_0_765366865, fIX_0_899976223, fIX_1_175875602, + fIX_1_501321110, fIX_1_847759065, fIX_1_961570560, + fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32 +fIX_0_298631336 = 2446 -- FIX(0.298631336) */ +fIX_0_390180644 = 3196 -- FIX(0.390180644) */ +fIX_0_541196100 = 4433 -- FIX(0.541196100) */ +fIX_0_765366865 = 6270 -- FIX(0.765366865) */ +fIX_0_899976223 = 7373 -- FIX(0.899976223) */ +fIX_1_175875602 = 9633 -- FIX(1.175875602) */ +fIX_1_501321110 = 12299 -- FIX(1.501321110) */ +fIX_1_847759065 = 15137 -- FIX(1.847759065) */ +fIX_1_961570560 = 16069 -- FIX(1.961570560) */ +fIX_2_053119869 = 16819 -- FIX(2.053119869) */ +fIX_2_562915447 = 20995 -- FIX(2.562915447) */ +fIX_3_072711026 = 25172 -- FIX(3.072711026) */ + +cENTERJSAMPLE :: Int32 +cENTERJSAMPLE = 128 + +-- | Fast DCT extracted from libjpeg +fastDctLibJpeg :: MutableMacroBlock s Int32 + -> MutableMacroBlock s Int16 + -> ST s (MutableMacroBlock s Int32) +fastDctLibJpeg workData sample_block = do + firstPass workData 0 + secondPass workData 7 + {-_ <- mutate (\_ a -> a `quot` 8) workData-} + return workData + where -- Pass 1: process rows. + -- Note results are scaled up by sqrt(8) compared to a true DCT; + -- furthermore, we scale the results by 2**PASS1_BITS. + firstPass _ i | i == dctBlockSize = return () + firstPass dataBlock i = do + let baseIdx = i * dctBlockSize + readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) + mult = (*) + writeAt idx = dataBlock `M.unsafeWrite` (baseIdx + idx) + writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) + (n `unsafeShiftR` (cONST_BITS - pASS1_BITS)) + + blk0 <- readAt 0 + blk1 <- readAt 1 + blk2 <- readAt 2 + blk3 <- readAt 3 + blk4 <- readAt 4 + blk5 <- readAt 5 + blk6 <- readAt 6 + blk7 <- readAt 7 + + let tmp0 = blk0 + blk7 + tmp1 = blk1 + blk6 + tmp2 = blk2 + blk5 + tmp3 = blk3 + blk4 + + tmp10 = tmp0 + tmp3 + tmp12 = tmp0 - tmp3 + tmp11 = tmp1 + tmp2 + tmp13 = tmp1 - tmp2 + + tmp0' = blk0 - blk7 + tmp1' = blk1 - blk6 + tmp2' = blk2 - blk5 + tmp3' = blk3 - blk4 + + -- Stage 4 and output + writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1)) + + writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 + writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 + + let tmp10' = tmp0' + tmp3' + tmp11' = tmp1' + tmp2' + tmp12' = tmp0' + tmp2' + tmp13' = tmp1' + tmp3' + z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */ + -- Add fudge factor here for final descale. */ + + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1)) + tmp0'' = mult tmp0' fIX_1_501321110 + tmp1'' = mult tmp1' fIX_3_072711026 + tmp2'' = mult tmp2' fIX_2_053119869 + tmp3'' = mult tmp3' fIX_0_298631336 + + tmp10'' = mult tmp10' (- fIX_0_899976223) + tmp11'' = mult tmp11' (- fIX_2_562915447) + tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' + tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' + + writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' + writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' + writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' + writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' + + firstPass dataBlock $ i + 1 + + -- Pass 2: process columns. + -- We remove the PASS1_BITS scaling, but leave the results scaled up + -- by an overall factor of 8. + secondPass :: M.STVector s Int32 -> Int -> ST s () + secondPass _ (-1) = return () + secondPass block i = do + let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize) + mult = (*) + writeAt idx = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i)) + writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3) + blk0 <- readAt 0 + blk1 <- readAt 1 + blk2 <- readAt 2 + blk3 <- readAt 3 + blk4 <- readAt 4 + blk5 <- readAt 5 + blk6 <- readAt 6 + blk7 <- readAt 7 + + let tmp0 = blk0 + blk7 + tmp1 = blk1 + blk6 + tmp2 = blk2 + blk5 + tmp3 = blk3 + blk4 + + -- Add fudge factor here for final descale. */ + tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1)) + tmp12 = tmp0 - tmp3 + tmp11 = tmp1 + tmp2 + tmp13 = tmp1 - tmp2 + + tmp0' = blk0 - blk7 + tmp1' = blk1 - blk6 + tmp2' = blk2 - blk5 + tmp3' = blk3 - blk4 + + writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3) + writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) + + let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1)) + + writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 + writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 + + let tmp10' = tmp0' + tmp3' + tmp11' = tmp1' + tmp2' + tmp12' = tmp0' + tmp2' + tmp13' = tmp1' + tmp3' + + z1' = mult (tmp12' + tmp13') fIX_1_175875602 + -- Add fudge factor here for final descale. */ + + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1); + + tmp0'' = mult tmp0' fIX_1_501321110 + tmp1'' = mult tmp1' fIX_3_072711026 + tmp2'' = mult tmp2' fIX_2_053119869 + tmp3'' = mult tmp3' fIX_0_298631336 + tmp10'' = mult tmp10' (- fIX_0_899976223) + tmp11'' = mult tmp11' (- fIX_2_562915447) + tmp12'' = mult tmp12' (- fIX_0_390180644) + + z1' + tmp13'' = mult tmp13' (- fIX_1_961570560) + + z1' + writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' + writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' + writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' + writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' + + secondPass block (i - 1) + +{-# ANN module "HLint: ignore Use camelCase" #-} +{-# ANN module "HLint: ignore Reduce duplication" #-} + diff --git a/src/Codec/Picture/Jpg/Metadata.hs b/src/Codec/Picture/Jpg/Metadata.hs --- a/src/Codec/Picture/Jpg/Metadata.hs +++ b/src/Codec/Picture/Jpg/Metadata.hs @@ -1,41 +1,41 @@ -{-# LANGUAGE CPP #-} -module Codec.Picture.Jpg.Metadata ( extractMetadatas, encodeMetadatas ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( pure ) -import Data.Monoid( mempty ) -import Data.Word( Word ) -#endif - -import Data.Word( Word16 ) -import Data.Maybe( fromMaybe ) -import qualified Codec.Picture.Metadata as Met -import Codec.Picture.Metadata( Metadatas ) -import Codec.Picture.Jpg.Types - -scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas -scalerOfUnit unit k v = case unit of - JFifUnitUnknown -> id - JFifPixelsPerInch -> Met.insert k (fromIntegral v) - JFifPixelsPerCentimeter -> - Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v) - -extractMetadatas :: JpgJFIFApp0 -> Metadatas -extractMetadatas jfif = - inserter Met.DpiX (_jfifDpiX jfif) - $ inserter Met.DpiY (_jfifDpiY jfif) mempty - where - inserter = scalerOfUnit $ _jfifUnit jfif - - -encodeMetadatas :: Metadatas -> [JpgFrame] -encodeMetadatas metas = fromMaybe [] $ do - dpiX <- Met.lookup Met.DpiX metas - dpiY <- Met.lookup Met.DpiY metas - pure . pure . JpgJFIF $ JpgJFIFApp0 - { _jfifUnit = JFifPixelsPerInch - , _jfifDpiX = fromIntegral dpiX - , _jfifDpiY = fromIntegral dpiY - , _jfifThumbnail = Nothing - } - +{-# LANGUAGE CPP #-} +module Codec.Picture.Jpg.Metadata ( extractMetadatas, encodeMetadatas ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( pure ) +import Data.Monoid( mempty ) +import Data.Word( Word ) +#endif + +import Data.Word( Word16 ) +import Data.Maybe( fromMaybe ) +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata( Metadatas ) +import Codec.Picture.Jpg.Types + +scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas +scalerOfUnit unit k v = case unit of + JFifUnitUnknown -> id + JFifPixelsPerInch -> Met.insert k (fromIntegral v) + JFifPixelsPerCentimeter -> + Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v) + +extractMetadatas :: JpgJFIFApp0 -> Metadatas +extractMetadatas jfif = + inserter Met.DpiX (_jfifDpiX jfif) + $ inserter Met.DpiY (_jfifDpiY jfif) mempty + where + inserter = scalerOfUnit $ _jfifUnit jfif + + +encodeMetadatas :: Metadatas -> [JpgFrame] +encodeMetadatas metas = fromMaybe [] $ do + dpiX <- Met.lookup Met.DpiX metas + dpiY <- Met.lookup Met.DpiY metas + pure . pure . JpgJFIF $ JpgJFIFApp0 + { _jfifUnit = JFifPixelsPerInch + , _jfifDpiX = fromIntegral dpiX + , _jfifDpiY = fromIntegral dpiY + , _jfifThumbnail = Nothing + } + diff --git a/src/Codec/Picture/Png.hs b/src/Codec/Picture/Png.hs --- a/src/Codec/Picture/Png.hs +++ b/src/Codec/Picture/Png.hs @@ -26,8 +26,6 @@ , writePng , encodeDynamicPng - , encodePalettedPng - , encodePalettedPngWithMetadata , writeDynamicPng ) where diff --git a/src/Codec/Picture/Png/Metadata.hs b/src/Codec/Picture/Png/Metadata.hs --- a/src/Codec/Picture/Png/Metadata.hs +++ b/src/Codec/Picture/Png/Metadata.hs @@ -1,135 +1,135 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -module Codec.Picture.Png.Metadata( extractMetadatas - , encodeMetadatas - ) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>), pure ) -import Data.Monoid( Monoid, mempty ) -import Data.Foldable( foldMap ) -#endif - -import Data.Maybe( fromMaybe ) -import Data.Binary( Binary( get, put ), encode ) -import Data.Binary.Get( getLazyByteStringNul ) -import Data.Binary.Put( putLazyByteString, putWord8 ) -import qualified Data.ByteString.Lazy.Char8 as L -import Data.Monoid( (<>) ) - -import Codec.Picture.InternalHelper -import qualified Codec.Picture.Metadata as Met -import Codec.Picture.Metadata ( Metadatas - , dotsPerMeterToDotPerInch - , Elem( (:=>) ) ) -import Codec.Picture.Png.Type - -#if !MIN_VERSION_base(4,7,0) -eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m -eitherFoldMap f v = case v of - Left _ -> mempty - Right a -> f a -#else -eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m -eitherFoldMap = foldMap -#endif - -getGamma :: [L.ByteString] -> Metadatas -getGamma [] = mempty -getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g - where - unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma) - -getDpis :: [L.ByteString] -> Metadatas -getDpis [] = mempty -getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b - where - unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } = - Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72 - unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } = - Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy - where - dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy - dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy - -data PngText = PngText - { pngKeyword :: !L.ByteString - , pngData :: !L.ByteString - } - deriving Show - -instance Binary PngText where - get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes - put (PngText kw pdata) = do - putLazyByteString kw - putWord8 0 - putLazyByteString pdata - -textToMetadata :: PngText -> Metadatas -textToMetadata ptext = case pngKeyword ptext of - "Title" -> strValue Met.Title - "Author" -> strValue Met.Author - "Description" -> strValue Met.Description - "Copyright" -> strValue Met.Copyright - {-"Creation Time" -> strValue Creation-} - "Software" -> strValue Met.Software - "Disclaimer" -> strValue Met.Disclaimer - "Warning" -> strValue Met.Warning - "Source" -> strValue Met.Source - "Comment" -> strValue Met.Comment - other -> - Met.singleton - (Met.Unknown $ L.unpack other) - (Met.String . L.unpack $ pngData ptext) - where - strValue k = Met.singleton k . L.unpack $ pngData ptext - -getTexts :: [L.ByteString] -> Metadatas -getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where - - -extractMetadatas :: PngRawImage -> Metadatas -extractMetadatas img = getDpis (chunksOf pHYsSignature) - <> getGamma (chunksOf gammaSignature) - <> getTexts (chunksOf tEXtSignature) - where - chunksOf = chunksWithSig img - -encodePhysicalMetadata :: Metadatas -> [PngRawChunk] -encodePhysicalMetadata metas = fromMaybe [] $ do - dx <- Met.lookup Met.DpiX metas - dy <- Met.lookup Met.DpiY metas - let to = fromIntegral . Met.dotPerInchToDotsPerMeter - dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter - pure [mkRawChunk pHYsSignature $ encode dim] - -encodeSingleMetadata :: Metadatas -> [PngRawChunk] -encodeSingleMetadata = Met.foldMap go where - go :: Elem Met.Keys -> [PngRawChunk] - go v = case v of - Met.Exif _ :=> _ -> mempty - Met.DpiX :=> _ -> mempty - Met.DpiY :=> _ -> mempty - Met.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) - Met.Description :=> tx -> txt "Description" (L.pack tx) - Met.Author :=> tx -> txt "Author" (L.pack tx) - Met.Copyright :=> tx -> txt "Copyright" (L.pack tx) - Met.Software :=> tx -> txt "Software" (L.pack tx) - Met.Comment :=> tx -> txt "Comment" (L.pack tx) - Met.Disclaimer :=> tx -> txt "Disclaimer" (L.pack tx) - Met.Source :=> tx -> txt "Source" (L.pack tx) - Met.Warning :=> tx -> txt "Warning" (L.pack tx) - Met.Unknown k :=> Met.String tx -> txt (L.pack k) (L.pack tx) - Met.Unknown _ :=> _ -> mempty - - txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c - -encodeMetadatas :: Metadatas -> [PngRawChunk] -encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m - +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +module Codec.Picture.Png.Metadata( extractMetadatas + , encodeMetadatas + ) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Monoid( Monoid, mempty ) +import Data.Foldable( foldMap ) +#endif + +import Data.Maybe( fromMaybe ) +import Data.Binary( Binary( get, put ), encode ) +import Data.Binary.Get( getLazyByteStringNul ) +import Data.Binary.Put( putLazyByteString, putWord8 ) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.Monoid( (<>) ) + +import Codec.Picture.InternalHelper +import qualified Codec.Picture.Metadata as Met +import Codec.Picture.Metadata ( Metadatas + , dotsPerMeterToDotPerInch + , Elem( (:=>) ) ) +import Codec.Picture.Png.Type + +#if !MIN_VERSION_base(4,7,0) +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap f v = case v of + Left _ -> mempty + Right a -> f a +#else +eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m +eitherFoldMap = foldMap +#endif + +getGamma :: [L.ByteString] -> Metadatas +getGamma [] = mempty +getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g + where + unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma) + +getDpis :: [L.ByteString] -> Metadatas +getDpis [] = mempty +getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b + where + unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } = + Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72 + unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } = + Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy + where + dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy + dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy + +data PngText = PngText + { pngKeyword :: !L.ByteString + , pngData :: !L.ByteString + } + deriving Show + +instance Binary PngText where + get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes + put (PngText kw pdata) = do + putLazyByteString kw + putWord8 0 + putLazyByteString pdata + +textToMetadata :: PngText -> Metadatas +textToMetadata ptext = case pngKeyword ptext of + "Title" -> strValue Met.Title + "Author" -> strValue Met.Author + "Description" -> strValue Met.Description + "Copyright" -> strValue Met.Copyright + {-"Creation Time" -> strValue Creation-} + "Software" -> strValue Met.Software + "Disclaimer" -> strValue Met.Disclaimer + "Warning" -> strValue Met.Warning + "Source" -> strValue Met.Source + "Comment" -> strValue Met.Comment + other -> + Met.singleton + (Met.Unknown $ L.unpack other) + (Met.String . L.unpack $ pngData ptext) + where + strValue k = Met.singleton k . L.unpack $ pngData ptext + +getTexts :: [L.ByteString] -> Metadatas +getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where + + +extractMetadatas :: PngRawImage -> Metadatas +extractMetadatas img = getDpis (chunksOf pHYsSignature) + <> getGamma (chunksOf gammaSignature) + <> getTexts (chunksOf tEXtSignature) + where + chunksOf = chunksWithSig img + +encodePhysicalMetadata :: Metadatas -> [PngRawChunk] +encodePhysicalMetadata metas = fromMaybe [] $ do + dx <- Met.lookup Met.DpiX metas + dy <- Met.lookup Met.DpiY metas + let to = fromIntegral . Met.dotPerInchToDotsPerMeter + dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter + pure [mkRawChunk pHYsSignature $ encode dim] + +encodeSingleMetadata :: Metadatas -> [PngRawChunk] +encodeSingleMetadata = Met.foldMap go where + go :: Elem Met.Keys -> [PngRawChunk] + go v = case v of + Met.Exif _ :=> _ -> mempty + Met.DpiX :=> _ -> mempty + Met.DpiY :=> _ -> mempty + Met.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) + Met.Description :=> tx -> txt "Description" (L.pack tx) + Met.Author :=> tx -> txt "Author" (L.pack tx) + Met.Copyright :=> tx -> txt "Copyright" (L.pack tx) + Met.Software :=> tx -> txt "Software" (L.pack tx) + Met.Comment :=> tx -> txt "Comment" (L.pack tx) + Met.Disclaimer :=> tx -> txt "Disclaimer" (L.pack tx) + Met.Source :=> tx -> txt "Source" (L.pack tx) + Met.Warning :=> tx -> txt "Warning" (L.pack tx) + Met.Unknown k :=> Met.String tx -> txt (L.pack k) (L.pack tx) + Met.Unknown _ :=> _ -> mempty + + txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c + +encodeMetadatas :: Metadatas -> [PngRawChunk] +encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m + diff --git a/src/Codec/Picture/VectorByteConversion.hs b/src/Codec/Picture/VectorByteConversion.hs --- a/src/Codec/Picture/VectorByteConversion.hs +++ b/src/Codec/Picture/VectorByteConversion.hs @@ -1,45 +1,45 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE CPP #-} -module Codec.Picture.VectorByteConversion( blitVector - , toByteString - , imageFromUnsafePtr ) where - -import Data.Word( Word8 ) -import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) -import Foreign.Storable( Storable, sizeOf ) - -#if !MIN_VERSION_base(4,8,0) -import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) -#else -import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) -#endif - - -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as S - -import Codec.Picture.Types - -blitVector :: Vector Word8 -> Int -> Int -> B.ByteString -blitVector vec atIndex = S.PS ptr (offset + atIndex) - where (ptr, offset, _length) = unsafeToForeignPtr vec - -toByteString :: forall a. (Storable a) => Vector a -> B.ByteString -toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) - where (ptr, offset, len) = unsafeToForeignPtr vec - size = sizeOf (undefined :: a) - --- | Import a image from an unsafe pointer --- The pointer must have a size of width * height * componentCount px -imageFromUnsafePtr :: forall px - . (Pixel px, (PixelBaseComponent px) ~ Word8) - => Int -- ^ Width in pixels - -> Int -- ^ Height in pixels - -> ForeignPtr Word8 -- ^ Pointer to the raw data - -> Image px -imageFromUnsafePtr width height ptr = - Image width height $ unsafeFromForeignPtr0 ptr size - where compCount = componentCount (undefined :: px) - size = width * height * compCount - +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE CPP #-} +module Codec.Picture.VectorByteConversion( blitVector + , toByteString + , imageFromUnsafePtr ) where + +import Data.Word( Word8 ) +import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) +import Foreign.Storable( Storable, sizeOf ) + +#if !MIN_VERSION_base(4,8,0) +import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) +#else +import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) +#endif + + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as S + +import Codec.Picture.Types + +blitVector :: Vector Word8 -> Int -> Int -> B.ByteString +blitVector vec atIndex = S.PS ptr (offset + atIndex) + where (ptr, offset, _length) = unsafeToForeignPtr vec + +toByteString :: forall a. (Storable a) => Vector a -> B.ByteString +toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) + where (ptr, offset, len) = unsafeToForeignPtr vec + size = sizeOf (undefined :: a) + +-- | Import a image from an unsafe pointer +-- The pointer must have a size of width * height * componentCount px +imageFromUnsafePtr :: forall px + . (Pixel px, (PixelBaseComponent px) ~ Word8) + => Int -- ^ Width in pixels + -> Int -- ^ Height in pixels + -> ForeignPtr Word8 -- ^ Pointer to the raw data + -> Image px +imageFromUnsafePtr width height ptr = + Image width height $ unsafeFromForeignPtr0 ptr size + where compCount = componentCount (undefined :: px) + size = width * height * compCount +