JuicyPixels 3.1.4.1 → 3.1.5
raw patch · 10 files changed
+327/−145 lines, 10 files
Files
- JuicyPixels.cabal +4/−3
- changelog +17/−0
- src/Codec/Picture.hs +5/−5
- src/Codec/Picture/Bitmap.hs +43/−18
- src/Codec/Picture/Gif.hs +13/−0
- src/Codec/Picture/Jpg.hs +37/−20
- src/Codec/Picture/Jpg/Progressive.hs +15/−13
- src/Codec/Picture/Png.hs +20/−17
- src/Codec/Picture/Tiff.hs +83/−21
- src/Codec/Picture/Types.hs +90/−48
JuicyPixels.cabal view
@@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.1.4.1 +Version: 3.1.5 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) Description: <<data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAAMAAAADABAMAAACg8nE0AAAAElBMVEUAAABJqDSTWEL/qyb///8AAABH/1GTAAAAAXRSTlMAQObYZgAAAN5JREFUeF7s1sEJgFAQxFBbsAV72v5bEVYWPwT/XDxmCsi7zvHXavYREBDI3XP2GgICqBBYuwIC+/rVayPUAyAg0HvIXBcQoDFDGnUBgWQQ2Bx3AYFaRoBpAQHWb3bt2ARgGAiCYFFuwf3X5HA/McgGJWI2FdykCv4aBYzmKwDwvl6NVmUAAK2vlwEALK7fo88GANB6HQsAAAAAAAAA7P94AQCzswEAAAAAAAAAAAAAAAAAAICzh4UAO4zWAYBfRutHA4Bn5C69JhowAMGoBaMWDG0wCkbBKBgFo2AUAACPmegUST/IJAAAAABJRU5ErkJggg==>> @@ -27,7 +27,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1.4.1 + Tag: v3.1.5 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -48,13 +48,14 @@ Codec.Picture.ColorQuant Ghc-options: -O3 -Wall + Ghc-prof-options: -rtsopts -Wall -prof -auto-all Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.2, binary >= 0.5 && < 0.8, zlib >= 0.5.3.1 && < 0.6, transformers >= 0.2.2 && < 0.4, - vector >= 0.9 && < 0.11, + vector >= 0.9 && < 0.11, primitive >= 0.5 && < 0.6, deepseq >= 1.1 && < 1.4, containers >= 0.4.2 && < 0.6
changelog view
@@ -1,5 +1,22 @@ -*-change-log-*- +v3.1.5 March 2014 + * Typos and documentation proof reading fixes + (pull request from iger). + * Fix of progressive jpeg loading with more than two + huffman tables (4 allowed). + * Fix of progressive jpeg rendering (was too noisy before) + * Added loading of paletted bitmap files. + * Function to load gif images with frame duration + information (pull request from bit-shift) + * Fixing bug showing when loading JPEG with component + ID starting at 0. + * Adding reading for YA8 et YA16 Tiff images (pull + request from iger) + * Adding a mixWithAlpha method, to help work on transparent + pixel types + + v3.1.4.1 February 2014 * Putting back data URI logo for cabal description, it's apparently not supported by Hackage :-(
src/Codec/Picture.hs view
@@ -197,7 +197,7 @@ [(pal, delay, img) | (img, pal) <- palettize defaultPaletteOptions <$> lst] --- | Helper function to write a gif animtion on disk. +-- | Helper function to write a gif animation on disk. -- See encodeGifAnimation writeGifAnimation :: FilePath -> GifDelay -> GifLooping -> [Image PixelRGB8] -> Either String (IO ()) @@ -216,7 +216,7 @@ get = B.readFile path #endif -- force appeared in deepseq 1.3, Haskell Platform - -- provide 1.1 + -- provides 1.1 force x = x `deepseq` x -- | Load an image file without even thinking about it, it does everything @@ -226,8 +226,8 @@ -- | If you want to decode an image in a bytestring without even thinking -- in term of format or whatever, this is the function to use. It will try --- to decode in each known format and if one decoding succeed will return --- the decoded image in it's own colorspace +-- to decode in each known format and if one decoding succeeds, it will return +-- the decoded image in it's own colorspace. decodeImage :: B.ByteString -> Either String DynamicImage decodeImage str = eitherLoad str [("Jpeg", decodeJpeg) ,("PNG", decodePng) @@ -256,7 +256,7 @@ -- | Try to load a jpeg file and decompress. The colorspace is still -- YCbCr if you want to perform computation on the luma part. You can --- convert it to RGB using 'colorSpaceConversion' +-- convert it to RGB using 'colorSpaceConversion'. readJpeg :: FilePath -> IO (Either String DynamicImage) readJpeg = withImageDecoder decodeJpeg
src/Codec/Picture/Bitmap.hs view
@@ -9,12 +9,13 @@ , decodeBitmap , encodeDynamicBitmap , writeDynamicBitmap - -- * Accepted formt in output + -- * Accepted format in output , BmpEncodable( ) ) where import Control.Monad( when, forM_ ) import Control.Monad.ST ( ST, runST ) -import qualified Data.Vector.Storable as V +import qualified Data.Vector as V +import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Data.Binary( Binary( .. ) ) import Data.Binary.Put( Put @@ -25,6 +26,7 @@ ) import Data.Binary.Get( Get + , getWord8 , getWord16le , getWord32le , bytesRead @@ -88,6 +90,7 @@ , colorCount :: !Word32 , importantColours :: !Word32 } + deriving Show sizeofBmpHeader, sizeofBmpInfo :: Word32 sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 @@ -169,14 +172,14 @@ let lineIdx = line * w inner col | col >= w = return () inner col = do - let v = (arr `V.unsafeIndex` (lineIdx + col)) + let v = (arr `VS.unsafeIndex` (lineIdx + col)) (buff `M.unsafeWrite` col) v inner (col + 1) inner 0 stridePut buff w stride - V.unsafeFreeze buff + VS.unsafeFreeze buff instance BmpEncodable PixelRGBA8 where bitsPerPixel _ = 32 @@ -188,10 +191,10 @@ let initialIndex = line * w * 4 inner col _ _ | col >= w = return () inner col writeIdx readIdx = do - let r = arr `V.unsafeIndex` readIdx - g = arr `V.unsafeIndex` (readIdx + 1) - b = arr `V.unsafeIndex` (readIdx + 2) - a = arr `V.unsafeIndex` (readIdx + 3) + let r = arr `VS.unsafeIndex` readIdx + g = arr `VS.unsafeIndex` (readIdx + 1) + b = arr `VS.unsafeIndex` (readIdx + 2) + a = arr `VS.unsafeIndex` (readIdx + 3) (buff `M.unsafeWrite` writeIdx) b (buff `M.unsafeWrite` (writeIdx + 1)) g @@ -201,7 +204,7 @@ inner (col + 1) (writeIdx + 4) (readIdx + 4) inner 0 0 initialIndex - V.unsafeFreeze buff + VS.unsafeFreeze buff instance BmpEncodable PixelRGB8 where bitsPerPixel _ = 24 @@ -214,9 +217,9 @@ let initialIndex = line * w * 3 inner col _ _ | col >= w = return () inner col writeIdx readIdx = do - let r = (arr `V.unsafeIndex` readIdx) - g = (arr `V.unsafeIndex` (readIdx + 1)) - b = (arr `V.unsafeIndex` (readIdx + 2)) + let r = (arr `VS.unsafeIndex` readIdx) + g = (arr `VS.unsafeIndex` (readIdx + 1)) + b = (arr `VS.unsafeIndex` (readIdx + 2)) (buff `M.unsafeWrite` writeIdx) b (buff `M.unsafeWrite` (writeIdx + 1)) g @@ -225,7 +228,7 @@ inner (col + 1) (writeIdx + 3) (readIdx + 3) inner 0 0 initialIndex - V.unsafeFreeze buff + VS.unsafeFreeze buff decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray @@ -234,7 +237,7 @@ stArray = runST $ do arr <- M.new (fromIntegral $ w * h * 3) forM_ [hi - 1, hi - 2 .. 0] (readLine arr) - V.unsafeFreeze arr + VS.unsafeFreeze arr stride = linePadding 24 wi readLine arr line = @@ -258,7 +261,7 @@ stArray = runST $ do arr <- M.new (fromIntegral $ w * h * 1) forM_ [hi - 1, hi - 2 .. 0] (readLine arr) - V.unsafeFreeze arr + VS.unsafeFreeze arr stride = linePadding 8 wi readLine arr line = @@ -273,6 +276,15 @@ in inner readIndex writeIndex + +pixelGet :: Get PixelRGB8 +pixelGet = do + b <- getWord8 + g <- getWord8 + r <- getWord8 + _ <- getWord8 + return $ PixelRGB8 r g b + -- | Try to decode a bitmap image. -- Right now this function can output the following pixel types : -- @@ -289,13 +301,27 @@ when (readed > fromIntegral (dataOffset hdr)) (fail "Invalid bmp image, data in header") - skip . fromIntegral $ dataOffset hdr - fromIntegral readed + let bpp = fromIntegral $ bitPerPixel bmpHeader :: Int + paletteColorCount + | colorCount bmpHeader == 0 = 2 ^ bpp + | otherwise = fromIntegral $ colorCount bmpHeader + + table <- if bpp > 8 + then return V.empty + else V.replicateM paletteColorCount pixelGet + + readed' <- bytesRead + + skip . fromIntegral $ dataOffset hdr - fromIntegral readed' rest <- getRemainingBytes case (bitPerPixel bmpHeader, planes bmpHeader, bitmapCompression bmpHeader) of -- (32, 1, 0) -> {- ImageRGBA8 <$>-} fail "Meuh" (24, 1, 0) -> return . ImageRGB8 $ decodeImageRGB8 bmpHeader rest - ( 8, 1, 0) -> return . ImageY8 $ decodeImageY8 bmpHeader rest + ( 8, 1, 0) -> + let indexer v = table V.! fromIntegral v in + return . ImageRGB8 . pixelMap indexer $ decodeImageY8 bmpHeader rest + a -> fail $ "Can't handle BMP file " ++ show a @@ -334,7 +360,6 @@ encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" - -- | Convert an image to a bytestring ready to be serialized. encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel)
src/Codec/Picture/Gif.hs view
@@ -2,6 +2,7 @@ module Codec.Picture.Gif ( -- * Reading decodeGif , decodeGifImages + , getDelaysGifImages -- * Writing , GifDelay @@ -487,6 +488,14 @@ paletteOf global GifImage { imgLocalPalette = Nothing } = global paletteOf _ GifImage { imgLocalPalette = Just p } = p +getFrameDelays :: GifFile -> [GifDelay] +getFrameDelays GifFile { gifImages = [] } = [] +getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs + where extractDelay (ext, _) = + case ext of + Nothing -> 0 + Just e -> fromIntegral $ gceDelay e + decodeAllGifImages :: GifFile -> [Image PixelRGB8] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette @@ -545,6 +554,10 @@ -- all the images of an animation. decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] decodeGifImages img = decodeAllGifImages <$> decode img + +-- | Extract a list of frame delays from a raw gif. +getDelaysGifImages :: B.ByteString -> Either String [GifDelay] +getDelaysGifImages img = getFrameDelays <$> decode img -- | Default palette to produce greyscale images. greyPalette :: Palette
src/Codec/Picture/Jpg.hs view
@@ -8,8 +8,6 @@ module Codec.Picture.Jpg( decodeJpeg , encodeJpegAtQuality , encodeJpeg - - , jpgMachineStep ) where import Control.Arrow( (>>>) ) @@ -224,12 +222,13 @@ RWS () [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] JpgDecoderState a data JpgDecoderState = JpgDecoderState - { dcDecoderTables :: !(V.Vector HuffmanPackedTree) - , acDecoderTables :: !(V.Vector HuffmanPackedTree) - , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) - , currentRestartInterv :: !Int - , currentFrame :: Maybe JpgFrameHeader - , isProgressive :: !Bool + { dcDecoderTables :: !(V.Vector HuffmanPackedTree) + , acDecoderTables :: !(V.Vector HuffmanPackedTree) + , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) + , currentRestartInterv :: !Int + , currentFrame :: Maybe JpgFrameHeader + , minimumComponentIndex :: !Int + , isProgressive :: !Bool , maximumHorizontalResolution :: !Int , maximumVerticalResolution :: !Int , seenBlobs :: !Int @@ -237,19 +236,22 @@ emptyDecoderState :: JpgDecoderState emptyDecoderState = JpgDecoderState - { dcDecoderTables = V.fromList $ map snd - [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable - , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable - ] + { dcDecoderTables = + let (_, dcLuma) = prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + (_, dcChroma) = prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable + in + V.fromList [ dcLuma, dcChroma, dcLuma, dcChroma ] - , acDecoderTables = V.fromList $ map snd - [ prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable - , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable - ] + , acDecoderTables = + let (_, acLuma) = prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + (_, acChroma) = prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable + in + V.fromList [acLuma, acChroma, acLuma, acChroma] , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1) , currentRestartInterv = -1 , currentFrame = Nothing + , minimumComponentIndex = 1 , isProgressive = False , maximumHorizontalResolution = 0 , maximumVerticalResolution = 0 @@ -264,16 +266,23 @@ jpgMachineStep (JpgScanBlob hdr raw_data) = do let scanCount = length $ scans hdr params <- concat <$> mapM (scanSpecifier scanCount) (scans hdr) + modify $ \st -> st { seenBlobs = seenBlobs st + 1 } tell [(params, raw_data) ] where (selectionLow, selectionHigh) = spectralSelection hdr approxHigh = fromIntegral $ successiveApproxHigh hdr approxLow = fromIntegral $ successiveApproxLow hdr + scanSpecifier scanCount scanSpec = do - let dcIndex = fromIntegral $ dcEntropyCodingTable scanSpec - acIndex = fromIntegral $ acEntropyCodingTable scanSpec - comp = fromIntegral (componentSelector scanSpec) - 1 + minimumIndex <- gets minimumComponentIndex + let maximumHuffmanTable = 4 + dcIndex = min (maximumHuffmanTable - 1) + . fromIntegral $ dcEntropyCodingTable scanSpec + acIndex = min (maximumHuffmanTable - 1) + . fromIntegral $ acEntropyCodingTable scanSpec + comp = fromIntegral (componentSelector scanSpec) - minimumIndex + dcTree <- gets $ (V.! dcIndex) . dcDecoderTables acTree <- gets $ (V.! acIndex) . acDecoderTables isProgressiveImage <- gets isProgressive @@ -319,6 +328,8 @@ jpgMachineStep (JpgScans kind hdr) = modify $ \s -> s { currentFrame = Just hdr + , minimumComponentIndex = + fromIntegral $ minimum [componentIdentifier comp | comp <- jpgComponents hdr] , isProgressive = case kind of JpgProgressiveDCTHuffman -> True _ -> False @@ -335,11 +346,15 @@ jpgMachineStep (JpgHuffmanTable tables) = mapM_ placeHuffmanTrees tables where placeHuffmanTrees (spec, tree) = case huffmanTableClass spec of DcComponent -> modify $ \s -> + if idx >= V.length (dcDecoderTables s) then s + else let neu = dcDecoderTables s // [(idx, tree)] in s { dcDecoderTables = neu `seq` neu } where idx = fromIntegral $ huffmanTableDest spec AcComponent -> modify $ \s -> + if idx >= V.length (acDecoderTables s) then s + else s { acDecoderTables = acDecoderTables s // [(idx, tree)] } where idx = fromIntegral $ huffmanTableDest spec @@ -394,7 +409,9 @@ let compIdx = componentIndex comp dcTree = dcHuffmanTree comp acTree = acHuffmanTree comp - qTable = quants V.! (min 1 compIdx) + quantId = fromIntegral . quantizationTableDest + $ jpgComponents frame !! compIdx + qTable = quants V.! (min 3 quantId) xd = blockMcuX comp yd = blockMcuY comp (subX, subY) = subSampling comp
src/Codec/Picture/Jpg/Progressive.hs view
@@ -113,11 +113,10 @@ v <- getNextBitJpg pure $ if v then plusOne else minusOne - {-performEobRun :: Int -> BoolReader s ()-} performEobRun idx | idx > maxIndex = pure () performEobRun idx = do coeff <- lift $ block `MS.unsafeRead` idx - when (coeff /= 0) $ do + if (coeff /= 0) then do bit <- getNextBitJpg case (bit, (coeff .&. plusOne) == 0) of (False, _) -> performEobRun $ idx + 1 @@ -127,14 +126,16 @@ | otherwise = coeff + minusOne lift $ (block `MS.unsafeWrite` idx) newVal performEobRun $ idx + 1 + else + performEobRun $ idx + 1 unpack idx | idx > maxIndex = pure 0 unpack idx = do rrrrssss <- decodeRrrrSsss $ acHuffmanTree params case rrrrssss of (0xF, 0) -> do - idx' <- updateCoeffs 0x10 idx - unpack $ idx' + idx' <- updateCoeffs 0xF idx + unpack $ idx' + 1 ( r, 0) -> do lowBits <- unpackInt r @@ -143,25 +144,24 @@ pure newEobRun ( r, _) -> do - idx' <- updateCoeffs (fromIntegral r) idx val <- getBitVal - when (idx <= maxIndex) $ + idx' <- updateCoeffs (fromIntegral r) idx + when (idx' <= maxIndex) $ (lift $ (block `MS.unsafeWrite` idx') val) unpack $ idx' + 1 updateCoeffs :: Int -> Int -> BoolReader s Int updateCoeffs r idx - | r < 0 = pure idx + | r < 0 = pure $ idx - 1 | idx > maxIndex = pure idx updateCoeffs r idx = do coeff <- lift $ block `MS.unsafeRead` idx if coeff /= 0 then do bit <- getNextBitJpg - when (bit && coeff .&. plusOne == 0) $ - if coeff >= 0 then - lift . (block `MS.unsafeWrite` idx) $ coeff + plusOne - else - lift . (block `MS.unsafeWrite` idx) $ coeff + minusOne + when (bit && coeff .&. plusOne == 0) $ do + let writeCoeff | coeff >= 0 = coeff + plusOne + | otherwise = coeff + minusOne + lift $ (block `MS.unsafeWrite` idx) writeCoeff updateCoeffs r $ idx + 1 else updateCoeffs (r - 1) $ idx + 1 @@ -279,8 +279,10 @@ forM_ allBlocks $ \compData -> do let compBlocks = componentBlocks compData cId = componentId compData - table = quants ! min 1 cId comp = jpgComponents frame !! cId + quantId = + fromIntegral $ quantizationTableDest comp + table = quants ! min 3 quantId compW = fromIntegral $ horizontalSamplingFactor comp compH = fromIntegral $ verticalSamplingFactor comp cw8 = maxiW - fromIntegral (horizontalSamplingFactor comp) + 1
src/Codec/Picture/Png.hs view
@@ -3,12 +3,15 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) --- files. The API has two layers, the high level, which load the image without --- looking deeply about it and the low level, allowing access to data chunks contained --- in the PNG image. +-- files. -- --- For general use, please use 'decodePng' function. +-- A high level API is provided. It loads and saves images for you +-- while hiding all the details about PNG chunks. -- +-- Basic functions for PNG handling are 'decodePng', 'encodePng' +-- and 'encodePalettedPng'. Convenience functions are provided +-- for direct file handling and using 'DynamicImage's. +-- -- The loader has been validated against the pngsuite (http://www.libpng.org/pub/png/pngsuite.html) module Codec.Picture.Png( -- * High level functions PngSavable( .. ) @@ -376,11 +379,11 @@ Right <$> V.unsafeFreeze imgArray generateGreyscalePalette :: Word8 -> PngPalette -generateGreyscalePalette times = Image possibilities 0 vec - where possibilities = 2 ^ times - 1 - vec = V.fromListN ((fromIntegral possibilities + 1) * 3) $ concat pixels - pixels = [[i, i, i] | n <- [0 .. possibilities] - , let i = fromIntegral $ n * (255 `div` possibilities)] +generateGreyscalePalette bits = Image (maxValue+1) 1 vec + where maxValue = 2 ^ bits - 1 + vec = V.fromListN ((fromIntegral maxValue + 1) * 3) $ concat pixels + pixels = [[i, i, i] | n <- [0 .. maxValue] + , let i = fromIntegral $ n * (255 `div` maxValue)] sampleCountOfImageType :: PngImageType -> Word32 sampleCountOfImageType PngGreyscale = 1 @@ -389,10 +392,10 @@ sampleCountOfImageType PngGreyscaleWithAlpha = 2 sampleCountOfImageType PngTrueColourWithAlpha = 4 -paletteRGBA1, paletteRGBA2, paletteRGBA4 :: PngPalette -paletteRGBA1 = generateGreyscalePalette 1 -paletteRGBA2 = generateGreyscalePalette 2 -paletteRGBA4 = generateGreyscalePalette 4 +paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette +paletteRGB1 = generateGreyscalePalette 1 +paletteRGB2 = generateGreyscalePalette 2 +paletteRGB4 = generateGreyscalePalette 4 {-# INLINE bounds #-} bounds :: Storable a => V.Vector a -> (Int, Int) @@ -417,7 +420,7 @@ -- in the future. -- The resulting image let you manage the pixel types. -- --- This function can output the following pixel types : +-- This function can output the following pixel types: -- -- * PixelY8 -- @@ -468,9 +471,9 @@ , chunkType chunk == tRNSSignature ] unparse _ t PngGreyscale bytes - | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) t PngIndexedColor bytes - | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) t PngIndexedColor bytes - | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) t PngIndexedColor bytes + | bitDepth ihdr == 1 = unparse (Just paletteRGB1) t PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse (Just paletteRGB2) t PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse (Just paletteRGB4) t PngIndexedColor bytes | otherwise = toImage ImageY8 ImageY16 $ runST stArray where stArray = deinterlacer ihdr bytes
src/Codec/Picture/Tiff.hs view
@@ -6,7 +6,7 @@ {-# LANGUAGE ScopedTypeVariables #-} -- | Module implementing TIFF decoding. -- --- Supported compression schemes : +-- Supported compression schemes: -- -- * Uncompressed -- @@ -14,7 +14,7 @@ -- -- * LZW -- --- Supported bit depth : +-- Supported bit depth: -- -- * 2 bits -- @@ -501,7 +501,16 @@ instance Show (Image PixelRGB16) where show _ = "Image PixelRGB16" -} +data ExtraSample + = ExtraSampleUnspecified -- ^ 0 + | ExtraSampleAssociatedAlpha -- ^ 1 + | ExtraSampleUnassociatedAlpha -- ^ 2 +codeOfExtraSample :: ExtraSample -> Word16 +codeOfExtraSample ExtraSampleUnspecified = 0 +codeOfExtraSample ExtraSampleAssociatedAlpha = 1 +codeOfExtraSample ExtraSampleUnassociatedAlpha = 2 + data TiffInfo = TiffInfo { tiffHeader :: TiffHeader , tiffWidth :: Word32 @@ -517,6 +526,7 @@ , tiffOffsets :: V.Vector Word32 , tiffPalette :: Maybe (Image PixelRGB16) , tiffYCbCrSubsampling :: V.Vector Word32 + , tiffExtraSample :: Maybe ExtraSample } data TiffColorspace = @@ -644,7 +654,7 @@ mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker. -> Endianness -> M.STVector s Word8 -- ^ Temporary buffer handling decompression. - -> Int -- ^ Line size in pixels + -> Int -- ^ Line size in pixels -> Int -- ^ Write index, in bytes -> Word32 -- ^ size, in bytes -> Int -- ^ Stride @@ -906,18 +916,26 @@ case tiffPlaneConfiguration nfo of PlanarConfigContig -> V.mapM_ unpacker sizes - where unpacker (idx, offset, size) = do + where unpacker (idx, stripSampleCount, offset, packedSize) = do let (writeIdx, tempStride) = offsetStride comp idx 1 _ <- uncompressAt compression str tempVec tempStride - writeIdx (offset, size) + writeIdx (offset, packedSize) + let typ :: M.MVector s a -> a + typ = const undefined + sampleSize = sizeOf (typ outVec) mergeBackTempBuffer comp endianness tempVec (width * sampleCount) - idx size 1 outVec + idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec - startWriteOffset = - V.generate stripCount(width * rowPerStrip * sampleCount *) - sizes = V.zip3 startWriteOffset (tiffOffsets nfo) (tiffStripSize nfo) + fullStripSampleCount = rowPerStrip * width * sampleCount + startWriteOffset = V.generate stripCount (fullStripSampleCount *) + stripSampleCounts = V.map strip startWriteOffset + where + strip start = min fullStripSampleCount (width * height * sampleCount - start) + sizes = V.zip4 startWriteOffset stripSampleCounts + (tiffOffsets nfo) (tiffStripSize nfo) + PlanarConfigSeparate -> V.mapM_ unpacker sizes where unpacker (idx, offset, size) = do let (writeIdx, tempStride) = offsetStride comp idx stride @@ -1032,6 +1050,10 @@ ifdMultiLong TagStripByteCounts $ tiffStripSize nfo + maybe (return ()) + (ifdShort TagExtraSample . codeOfExtraSample) + $ tiffExtraSample nfo + let subSampling = tiffYCbCrSubsampling nfo when (not $ V.null subSampling) $ ifdShorts TagYCbCrSubsampling subSampling @@ -1075,6 +1097,7 @@ >>= unLong "Can't find strip offsets") <*> findPalette cleaned <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) + <*> pure Nothing unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage -- | while mandatory some images don't put correct @@ -1122,25 +1145,42 @@ case img of ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i ImageY16 i -> pure . ImageY16 $ pixelMap (maxBound -) i - _ -> pure img + ImageYA8 i -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a + in pure . ImageYA8 $ pixelMap negative i + ImageYA16 i -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a + in pure . ImageYA16 $ pixelMap negative i + _ -> fail $ "Unsupported color type used with colorspace MonochromeWhite0" unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.singleton 2 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo + pure . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.singleton 4 && all (TiffSampleUint ==) format = - pure . ImageY8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo + pure . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.singleton 8 && all (TiffSampleUint ==) format = pure . ImageY8 $ gatherStrips (0 :: Word8) file nfo | lst == V.singleton 12 && all (TiffSampleUint ==) format = - pure . ImageY16 . pixelMap (16 *) $ gatherStrips Pack12 file nfo + pure . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.singleton 16 && all (TiffSampleUint ==) format = pure . ImageY16 $ gatherStrips (0 :: Word16) file nfo | lst == V.singleton 32 && all (TiffSampleUint ==) format = + let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 + img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + in pure . ImageY16 $ pixelMap (toWord16) img - where toWord16 v = fromIntegral $ v `unsafeShiftR` 16 - img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 + | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = + pure . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo + | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = + pure . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo + | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = + pure . ImageYA8 $ gatherStrips (0 :: Word8) file nfo + | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = + pure . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo + | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = + pure . ImageYA16 $ gatherStrips (0 :: Word16) file nfo + where + expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr , tiffBitsPerSample = lst @@ -1164,9 +1204,9 @@ , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (64 *)) $ gatherStrips Pack2 file nfo + pure . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = - pure . ImageRGB8 . pixelMap (colorMap (16 *)) $ gatherStrips Pack4 file nfo + pure . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = pure . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = @@ -1184,19 +1224,27 @@ unpack _ _ = fail "Failure to unpack TIFF file" --- | Transform a raw tiff image to an image, without modifying --- the underlying pixel type. +-- | Decode a tiff encoded image while preserving the underlying +-- pixel type (except for Y32 which is truncated to 16 bits). -- --- This function can output the following pixel types : +-- This function can output the following pixel types: -- -- * PixelY8 -- -- * PixelY16 -- +-- * PixelYA8 +-- +-- * PixelYA16 +-- -- * PixelRGB8 -- -- * PixelRGB16 -- +-- * PixelRGBA8 +-- +-- * PixelRGBA16 +-- -- * PixelCMYK8 -- -- * PixelCMYK16 @@ -1209,6 +1257,9 @@ class (Pixel px) => TiffSaveable px where colorSpaceOfPixel :: px -> TiffColorspace + extraSampleCodeOfPixel :: px -> Maybe ExtraSample + extraSampleCodeOfPixel _ = Nothing + subSamplingInfo :: px -> V.Vector Word32 subSamplingInfo _ = V.empty @@ -1218,6 +1269,14 @@ instance TiffSaveable Pixel16 where colorSpaceOfPixel _ = TiffMonochrome +instance TiffSaveable PixelYA8 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + +instance TiffSaveable PixelYA16 where + colorSpaceOfPixel _ = TiffMonochrome + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha + instance TiffSaveable PixelCMYK8 where colorSpaceOfPixel _ = TiffCMYK @@ -1232,15 +1291,17 @@ instance TiffSaveable PixelRGBA8 where colorSpaceOfPixel _ = TiffRGB + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha instance TiffSaveable PixelRGBA16 where colorSpaceOfPixel _ = TiffRGB + extraSampleCodeOfPixel _ = Just ExtraSampleUnassociatedAlpha instance TiffSaveable PixelYCbCr8 where colorSpaceOfPixel _ = TiffYCbCr subSamplingInfo _ = V.fromListN 2 [1, 1] --- | Transform an image into a Tiff encoded bytestring, reade to be +-- | Transform an image into a Tiff encoded bytestring, ready to be -- written as a file. encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString encodeTiff img = runPut $ putP rawPixelData hdr @@ -1277,6 +1338,7 @@ , tiffOffsets = V.singleton headerSize , tiffPalette = Nothing , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) + , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px) } -- | Helper function to directly write an image as a tiff on disk.
src/Codec/Picture/Types.hs view
@@ -94,17 +94,31 @@ #include "ConvGraph.hs" --- | Image or pixel buffer, the coordinates are assumed to start --- from the upper-left corner of the image, with the horizontal --- position first, then the vertical one. +-- | The main type of this package, one that most +-- functions work on, is Image. +-- +-- Parameterized by the underlying pixel format it +-- forms a rigid type. If you wish to store images +-- of different or unknown pixel formats use 'DynamicImage'. +-- +-- Image is essentially a rectangular pixel buffer +-- of specified width and height. The coordinates are +-- assumed to start from the upper-left corner +-- of the image, with the horizontal position first +-- and vertical second. data Image a = Image { -- | Width of the image in pixels imageWidth :: {-# UNPACK #-} !Int -- | Height of the image in pixels. , imageHeight :: {-# UNPACK #-} !Int - -- | The real image, to extract pixels at some position - -- you should use the helpers functions. + -- | Image pixel data. To extract pixels at a given position + -- you should use the helper functions. + -- + -- Internally pixel data is stored as consecutively packed + -- lines from top to bottom, scanned from left to right + -- within individual lines, from first to last color + -- component within each pixel. , imageData :: V.Vector (PixelBaseComponent a) } @@ -161,10 +175,10 @@ data PlaneBlack = PlaneBlack -- | Extract a color plane from an image given a present plane in the image --- examples : +-- examples: -- -- @ --- extractRedPlane :: Image PixelRGB8-> Image Pixel8 +-- extractRedPlane :: Image PixelRGB8 -> Image Pixel8 -- extractRedPlane = extractComponent PlaneRed -- @ -- @@ -177,10 +191,11 @@ extractComponent plane = unsafeExtractComponent idx where idx = toComponentIndex (undefined :: px) plane --- | Extract an image plane of an image, returning an image which --- can be represented by a gray scale image. --- If you ask a component out of bound, the `error` function will --- be called +-- | Extract a plane of an image. Returns the requested color +-- component as a greyscale image. +-- +-- If you ask for a component out of bound, the `error` function will +-- be called. unsafeExtractComponent :: forall a . ( Pixel a , Pixel (PixelBaseComponent a) @@ -209,8 +224,8 @@ -- | access the transparency (alpha layer) of a given -- transparent pixel type. - -- DEPRECATED, you should use `pixelOpacity` getTransparency :: a -> PixelBaseComponent a +{-# DEPRECATED getTransparency "please use 'pixelOpacity' instead" #-} instance TransparentPixel PixelRGBA8 PixelRGB8 where {-# INLINE dropTransparency #-} @@ -292,8 +307,9 @@ dat `seq` () --- | Type allowing the loading of an image with different pixel --- structures +-- | Image type enumerating all predefined pixel types. +-- It enables loading and use of images of different +-- pixel types. data DynamicImage = -- | A greyscale image. ImageY8 (Image Pixel8) @@ -319,12 +335,12 @@ | ImageYCbCr8 (Image PixelYCbCr8) -- | An image in the colorspace CMYK | ImageCMYK8 (Image PixelCMYK8) - -- | An image in the colorspace CMYK and 16 bots precision + -- | An image in the colorspace CMYK and 16 bits precision | ImageCMYK16 (Image PixelCMYK16) -- | Helper function to help extract information from dynamic -- image. To get the width of a dynamic image, you can use --- the following snippet : +-- the following snippet: -- -- > dynWidth :: DynamicImage -> Int -- > dynWidth img = dynamicMap imageWidth img @@ -408,9 +424,8 @@ -- > map promotePixel [0, 1 .. 255 :: Pixel8] == [0/255, 1/255 .. 1.0 :: PixelF] type PixelF = Float --- | Pixel type storing Luminance (Y) and alpha information --- on 8 bits. --- Value are stored in the following order : +-- | Pixel type storing 8bit Luminance (Y) and alpha (A) information. +-- Values are stored in the following order: -- -- * Luminance -- @@ -420,9 +435,8 @@ {-# UNPACK #-} !Pixel8 -- Alpha value deriving (Eq, Ord, Show) --- | Pixel type storing Luminance (Y) and alpha information --- on 16 bits. --- Value are stored in the following order : +-- | Pixel type storing 16bit Luminance (Y) and alpha (A) information. +-- Values are stored in the following order: -- -- * Luminance -- @@ -432,8 +446,8 @@ {-# UNPACK #-} !Pixel16 -- Alpha value deriving (Eq, Ord, Show) --- | Pixel type storing classic pixel on 8 bits --- Value are stored in the following order : +-- | Classic pixel type storing 8bit red, green and blue (RGB) information. +-- Values are stored in the following order: -- -- * Red -- @@ -446,8 +460,8 @@ {-# UNPACK #-} !Pixel8 -- Blue deriving (Eq, Ord, Show) --- | Pixel type storing pixels on 16 bits --- Value are stored in the following order : +-- | Pixel type storing 16bit red, green and blue (RGB) information. +-- Values are stored in the following order: -- -- * Red -- @@ -460,8 +474,9 @@ {-# UNPACK #-} !Pixel16 -- Blue deriving (Eq, Ord, Show) --- | Pixel type storing HDR pixel on 32 bits float --- Values are stored in the following order : +-- | HDR pixel type storing floating point 32bit red, green and blue (RGB) information. +-- Same value range and comments apply as for 'PixelF'. +-- Values are stored in the following order: -- -- * Red -- @@ -474,22 +489,22 @@ {-# UNPACK #-} !PixelF -- Blue deriving (Eq, Ord, Show) --- | Pixel storing data in the YCbCr colorspace, --- values are stored in the following order : +-- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information. +-- Values are stored in the following order: -- -- * Y (luminance) -- --- * Cr --- -- * Cb -- +-- * Cr +-- data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance - {-# UNPACK #-} !Pixel8 -- Cr red difference {-# UNPACK #-} !Pixel8 -- Cb blue difference + {-# UNPACK #-} !Pixel8 -- Cr red difference deriving (Eq, Ord, Show) --- | Pixel storing data in the CMYK colorspace. Values --- are stored in the following order : +-- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information. +-- Values are stored in the following order: -- -- * Cyan -- @@ -505,8 +520,8 @@ {-# UNPACK #-} !Pixel8 -- Black deriving (Eq, Ord, Show) --- | Pixel storing data in the CMYK colorspace. Values --- are stored in the following order : +-- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information. +-- Values are stored in the following order: -- -- * Cyan -- @@ -523,8 +538,8 @@ deriving (Eq, Ord, Show) --- | Pixel type storing a classic pixel, with an alpha component. --- Values are stored in the following order +-- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information. +-- Values are stored in the following order: -- -- * Red -- @@ -540,9 +555,8 @@ {-# UNPACK #-} !Pixel8 -- Alpha deriving (Eq, Ord, Show) --- | Pixel type storing a RGB information with an alpha --- channel on 16 bits. --- Values are stored in the following order +-- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information. +-- Values are stored in the following order: -- -- * Red -- @@ -568,7 +582,7 @@ type PixelBaseComponent a :: * -- | Call the function for every component of the pixels. - -- For example for RGB pixels mixWith is declared like this : + -- For example for RGB pixels mixWith is declared like this: -- -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = -- > PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) @@ -576,16 +590,33 @@ mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a) -> a -> a -> a + -- | Extension of the `mixWith` which separate the treatment + -- of the color components of the alpha value (transparency component). + -- For pixel without alpha components, it is equivalent to mixWith. + -- + -- > mixWith f fa (PixelRGBA8 ra ga ba aa) (PixelRGB8 rb gb bb ab) = + -- > PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) + -- + mixWithAlpha :: (Int -> PixelBaseComponent a -> PixelBaseComponent a + -> PixelBaseComponent a) -- ^ Function for color component + -> (PixelBaseComponent a -> PixelBaseComponent a + -> PixelBaseComponent a) -- ^ Function for alpha component + -> a -> a -> a + {-# INLINE mixWithAlpha #-} + mixWithAlpha f _ = mixWith f + -- | Return the opacity of a pixel, if the pixel has an -- alpha layer, return the alpha value. If the pixel -- doesn't have an alpha value, return a value -- representing the opaqueness. pixelOpacity :: a -> PixelBaseComponent a - -- | Return the number of component of the pixel + -- | Return the number of components of the pixel componentCount :: a -> Int - -- | Apply a function to all color component of a pixel. + -- | Apply a function to each component of a pixel. + -- If the color type possess an alpha (transparency channel), + -- it is treated like the other color components. colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a -- | Calculate the index for the begining of the pixel @@ -656,7 +687,7 @@ -- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper -- left corner of the image, and (width-1, height-1) the lower right corner. -- --- for example, to create a small gradient image : +-- for example, to create a small gradient image: -- -- > imageCreator :: String -> IO () -- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 @@ -739,7 +770,7 @@ frozen <- V.unsafeFreeze arr return (foldResult, frozen) --- | Fold over the pixel of an image with a raster scan order : +-- | Fold over the pixel of an image with a raster scan order: -- from top to bottom, left to right {-# INLINE pixelFold #-} pixelFold :: (Pixel pixel) @@ -1150,6 +1181,10 @@ mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) = PixelYA16 (f 0 ya yb) (f 1 aa ab) + {-# INLINE mixWithAlpha #-} + mixWithAlpha f fa (PixelYA16 ya aa) (PixelYA16 yb ab) = + PixelYA16 (f 0 ya yb) (fa aa ab) + {-# INLINE colorMap #-} colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a) componentCount _ = 2 @@ -1197,7 +1232,6 @@ instance Pixel PixelRGBF where type PixelBaseComponent PixelRGBF = PixelF - {-# INLINE pixelOpacity #-} pixelOpacity = const 1.0 @@ -1398,6 +1432,10 @@ mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) + {-# INLINE mixWithAlpha #-} + mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = + PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) + {-# INLINE colorMap #-} colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) @@ -1463,6 +1501,10 @@ {-# INLINE mixWith #-} mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) + + {-# INLINE mixWithAlpha #-} + mixWithAlpha f fa (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = + PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) {-# INLINE colorMap #-} colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a)