JuicyPixels 3.1.6.1 → 3.1.7
raw patch · 14 files changed
+200/−79 lines, 14 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
+ Codec.Picture.HDR: encodeRLENewStyleHDR :: Image PixelRGBF -> ByteString
+ Codec.Picture.HDR: encodeRawHDR :: Image PixelRGBF -> ByteString
+ Codec.Picture.HDR: writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO ()
+ Codec.Picture.Types: pixelFoldM :: (Pixel pixel, Monad m) => (acc -> Int -> Int -> pixel -> m acc) -> acc -> Image pixel -> m acc
Files
- JuicyPixels.cabal +2/−2
- changelog +7/−0
- src/Codec/Picture.hs +1/−0
- src/Codec/Picture/Bitmap.hs +47/−34
- src/Codec/Picture/ColorQuant.hs +2/−0
- src/Codec/Picture/Gif.hs +42/−19
- src/Codec/Picture/HDR.hs +43/−2
- src/Codec/Picture/Jpg.hs +8/−3
- src/Codec/Picture/Jpg/Common.hs +1/−0
- src/Codec/Picture/Jpg/FastDct.hs +1/−0
- src/Codec/Picture/Jpg/FastIdct.hs +1/−0
- src/Codec/Picture/Jpg/Types.hs +1/−0
- src/Codec/Picture/Png.hs +17/−15
- src/Codec/Picture/Types.hs +27/−4
JuicyPixels.cabal view
@@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.1.6.1 +Version: 3.1.7 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==>> @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1.6.1 + Tag: v3.1.7 Flag Mmap Description: Enable the file loading via mmap (memory map)
changelog view
@@ -1,5 +1,12 @@ -*-change-log-*- +v3.1.7 August 2014 + * Making Juicy.Pixels compatible with GHC 7.9 HEAD (ggreif) + * Adding writing to uncompressed radiance file, due to + problems with Mac OS X "preview" application + * Fixing problem of gif parsing without global palette + * Some inlining annotations on some functions + v3.1.6.1 August 2014 * Fix of Gif palette creation (jeffreyrosenbluth) * Restoring transformers 0.3.* compat
src/Codec/Picture.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} -- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and
src/Codec/Picture/Bitmap.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeFamilies #-} -- | Modules used for Bitmap file (.bmp) file loading and writing module Codec.Picture.Bitmap( -- * Functions writeBitmap @@ -166,6 +167,7 @@ putVector vec = putByteString $ blitVector vec 0 lineWidth lineWidth = w + stride + encodeLine :: forall s. Int -> ST s (VS.Vector Word8) encodeLine line = do buff <- M.new lineWidth @@ -185,51 +187,58 @@ bitsPerPixel _ = 32 bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l - where putVector vec = putByteString . blitVector vec 0 $ w * 4 - putLine line = do - buff <- M.new $ 4 * w - let initialIndex = line * w * 4 - inner col _ _ | col >= w = return () - inner col writeIdx readIdx = do - let r = arr `VS.unsafeIndex` readIdx - g = arr `VS.unsafeIndex` (readIdx + 1) - b = arr `VS.unsafeIndex` (readIdx + 2) - a = arr `VS.unsafeIndex` (readIdx + 3) + where + putVector vec = putByteString . blitVector vec 0 $ w * 4 - (buff `M.unsafeWrite` writeIdx) b - (buff `M.unsafeWrite` (writeIdx + 1)) g - (buff `M.unsafeWrite` (writeIdx + 2)) r - (buff `M.unsafeWrite` (writeIdx + 3)) a + putLine :: forall s. Int -> ST s (VS.Vector Word8) + putLine line = do + buff <- M.new $ 4 * w + let initialIndex = line * w * 4 + inner col _ _ | col >= w = return () + inner col writeIdx readIdx = do + let r = arr `VS.unsafeIndex` readIdx + g = arr `VS.unsafeIndex` (readIdx + 1) + b = arr `VS.unsafeIndex` (readIdx + 2) + a = arr `VS.unsafeIndex` (readIdx + 3) - inner (col + 1) (writeIdx + 4) (readIdx + 4) + (buff `M.unsafeWrite` writeIdx) b + (buff `M.unsafeWrite` (writeIdx + 1)) g + (buff `M.unsafeWrite` (writeIdx + 2)) r + (buff `M.unsafeWrite` (writeIdx + 3)) a - inner 0 0 initialIndex - VS.unsafeFreeze buff + inner (col + 1) (writeIdx + 4) (readIdx + 4) + inner 0 0 initialIndex + VS.unsafeFreeze buff + instance BmpEncodable PixelRGB8 where bitsPerPixel _ = 24 bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ putLine l - where stride = fromIntegral . linePadding 24 $ w - putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride) - putLine line = do - buff <- M.new $ w * 3 + stride - let initialIndex = line * w * 3 - inner col _ _ | col >= w = return () - inner col writeIdx readIdx = do - 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 - (buff `M.unsafeWrite` (writeIdx + 2)) r + where + stride = fromIntegral . linePadding 24 $ w - inner (col + 1) (writeIdx + 3) (readIdx + 3) + putVector vec = putByteString $ blitVector vec 0 (w * 3 + stride) - inner 0 0 initialIndex - VS.unsafeFreeze buff + putLine :: forall s. Int -> ST s (VS.Vector Word8) + putLine line = do + buff <- M.new $ w * 3 + stride + let initialIndex = line * w * 3 + inner col _ _ | col >= w = return () + inner col writeIdx readIdx = do + 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 + (buff `M.unsafeWrite` (writeIdx + 2)) r + inner (col + 1) (writeIdx + 3) (readIdx + 3) + + inner 0 0 initialIndex + VS.unsafeFreeze buff + decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where wi = fromIntegral w @@ -240,6 +249,8 @@ VS.unsafeFreeze arr stride = linePadding 24 wi + + readLine :: forall s. M.MVector s Word8 -> Int -> ST s () readLine arr line = let readIndex = (wi * 3 + stride) * line lastIndex = wi * (hi - 1 - line + 1) * 3 @@ -264,6 +275,8 @@ VS.unsafeFreeze arr stride = linePadding 8 wi + + readLine :: forall s. M.MVector s Word8 -> Int -> ST s () readLine arr line = let readIndex = (wi * 1 + stride) * line lastIndex = wi * (hi - 1 - line + 1) * 1
src/Codec/Picture/ColorQuant.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | This module provide some color quantisation algorithm -- in order to help in the creation of paletted images. -- The most important function is `palettize` which will
src/Codec/Picture/Gif.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} -- | Module implementing GIF decoding. module Codec.Picture.Gif ( -- * Reading decodeGif @@ -39,6 +40,8 @@ , getWord8 , getWord16le , getByteString + , bytesRead + , skip ) import Data.Binary.Put( Put @@ -186,19 +189,17 @@ , gDescLocalColorTableSize :: !Word8 } -imageSeparator, extensionIntroducer, gifTrailer, applicationLabel :: Word8 +imageSeparator, extensionIntroducer, gifTrailer :: Word8 imageSeparator = 0x2C extensionIntroducer = 0x21 gifTrailer = 0x3B -applicationLabel = 0xFF -graphicControlLabel :: Word8 +graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 +plainTextLabel = 0x01 graphicControlLabel = 0xF9 +commentLabel = 0xFE +applicationLabel = 0xFF ---commentLabel, graphicControlLabel, --- -{-commentLabel = 0xFE-} -{-plainTextLabel = 0x01-} parseDataBlocks :: Get B.ByteString parseDataBlocks = B.concat <$> (getWord8 >>= aux) @@ -321,20 +322,35 @@ data Block = BlockImage GifImage | BlockGraphicControl GraphicControlExtension +skipSubDataBlocks :: Get () +skipSubDataBlocks = do + s <- fromIntegral <$> getWord8 + if s == 0 then + return () + else + skip s >> skipSubDataBlocks + parseGifBlocks :: Get [Block] parseGifBlocks = getWord8 >>= blockParse - where blockParse v - | v == gifTrailer = pure [] - | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks - | v == extensionIntroducer = do - extensionCode <- getWord8 - if extensionCode /= graphicControlLabel - then parseDataBlocks >> parseGifBlocks - else (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + where + blockParse v + | v == gifTrailer = pure [] + | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks + | v == extensionIntroducer = getWord8 >>= extensionParse - blockParse v = do - fail ("Unrecognized gif block " ++ show v) + blockParse v = do + readPosition <- bytesRead + fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) + extensionParse code + | code == graphicControlLabel = + (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks + | code == commentLabel = skipSubDataBlocks >> parseGifBlocks + | code `elem` [plainTextLabel, applicationLabel] = + fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks + | otherwise = parseDataBlocks >> parseGifBlocks + + instance Binary ImageDescriptor where put v = do putWord8 imageSeparator @@ -390,7 +406,8 @@ ---- Palette -------------------------------------------------- getPalette :: Word8 -> Get Palette -getPalette bitDepth = replicateM (size * 3) get >>= return . Image size 1 . V.fromList +getPalette bitDepth = + replicateM (size * 3) get >>= return . Image size 1 . V.fromList where size = 2 ^ (fromIntegral bitDepth :: Int) putPalette :: Int -> Palette -> Put @@ -419,7 +436,13 @@ get = do version <- get screenDesc <- get - palette <- getPalette $ colorTableSize screenDesc + + palette <- + if hasGlobalMap screenDesc then + getPalette $ colorTableSize screenDesc + else + return $ Image 0 1 V.empty + return GifHeader { gifVersion = version , gifScreenDescriptor = screenDesc
src/Codec/Picture/HDR.hs view
@@ -1,7 +1,14 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} -- | Module dedicated of Radiance file decompression (.hdr or .pic) file. -- Radiance file format is used for High dynamic range imaging. -module Codec.Picture.HDR( decodeHDR, encodeHDR, writeHDR ) where +module Codec.Picture.HDR( decodeHDR + , encodeHDR + , encodeRawHDR + , encodeRLENewStyleHDR + , writeHDR + , writeRLENewStyleHDR + ) where import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.Char( ord, chr, isDigit ) @@ -384,10 +391,44 @@ 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 pic = encode $ runST $ do +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
src/Codec/Picture/Jpg.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -fspec-constr-count=5 #-} -- | Module used for JPEG file loading and writing. module Codec.Picture.Jpg( decodeJpeg @@ -476,10 +477,11 @@ imgHeight = fromIntegral $ jpgHeight scanInfo imageSize = imgWidth * imgHeight * compCount - (st, wrotten) = execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - decodeProgressive = runST $ + decodeProgressive = runST $ do + let (st, wrotten) = + execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState + Just fHdr = currentFrame st progressiveUnpack (maximumHorizontalResolution st, maximumVerticalResolution st) fHdr @@ -487,6 +489,9 @@ wrotten >>= unsafeFreezeImage pixelData = runST $ do + let (st, wrotten) = + execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState + Just fHdr = currentFrame st resultImage <- M.new imageSize let wrapped = MutableImage imgWidth imgHeight resultImage decodeImage
src/Codec/Picture/Jpg/Common.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE TypeFamilies #-} module Codec.Picture.Jpg.Common ( DctCoefficients , JpgUnpackerParameter( .. )
src/Codec/Picture/Jpg/FastDct.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE TypeFamilies #-} module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where import Control.Applicative( (<$>) )
src/Codec/Picture/Jpg/FastIdct.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} -- | Module providing a 'fast' implementation of IDCT -- -- inverse two dimensional DCT, Chen-Wang algorithm
src/Codec/Picture/Jpg/Types.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Codec.Picture.Jpg.Types( MutableMacroBlock , createEmptyMutableMacroBlock , printMacroBlock
src/Codec/Picture/Png.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) -- files. -- @@ -454,11 +456,6 @@ + 1 {- Additional flags/check bits -} + 4 {-CRC-} - toImage const1 _const2 (Left a) = - Right . const1 $ Image (fromIntegral w) (fromIntegral h) a - toImage _const1 const2 (Right a) = - Right . const2 $ Image (fromIntegral w) (fromIntegral h) a - palette8 palette [c] (Left img) = Right . ImageRGBA8 . Image (fromIntegral w) (fromIntegral h) @@ -471,6 +468,16 @@ palette8 _ _ (Right _) = Left "Invalid bit depth for paleted image" + toImage :: forall a pxWord8 pxWord16 + . (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage) + -> Either (V.Vector (PixelBaseComponent pxWord8)) + (V.Vector (PixelBaseComponent pxWord16)) + -> Either a DynamicImage + toImage const1 _const2 (Left a) = + Right . const1 $ Image (fromIntegral w) (fromIntegral h) a + toImage _const1 const2 (Right a) = + Right . const2 $ Image (fromIntegral w) (fromIntegral h) a + transparencyColor = [ chunkData chunk | chunk <- chunks rawImg , chunkType chunk == tRNSSignature ] @@ -479,22 +486,17 @@ | 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 + | otherwise = toImage ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes unparse Nothing _ PngIndexedColor _ = Left "no valid palette found" unparse _ _ PngTrueColour bytes = - toImage ImageRGB8 ImageRGB16 $ runST stArray - where stArray = deinterlacer ihdr bytes + toImage ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes unparse _ _ PngGreyscaleWithAlpha bytes = - toImage ImageYA8 ImageYA16 $ runST stArray - where stArray = deinterlacer ihdr bytes + toImage ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes unparse _ _ PngTrueColourWithAlpha bytes = - toImage ImageRGBA8 ImageRGBA16 $ runST stArray - where stArray = deinterlacer ihdr bytes + toImage ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes unparse (Just plte) transparency PngIndexedColor bytes = - palette8 plte transparency $ runST stArray - where stArray = deinterlacer ihdr bytes + palette8 plte transparency $ runST $ deinterlacer ihdr bytes if Lb.length compressedImageData <= zlibHeaderSize then Left "Invalid data size"
src/Codec/Picture/Types.hs view
@@ -52,6 +52,8 @@ , pixelMap , pixelMapXY , pixelFold + , pixelFoldM + , dynamicMap , dynamicPixelMap , dropAlphaLayer @@ -245,6 +247,12 @@ where go n | n >= count = return () go n = f n >> go (n + 1) +lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a +{-# INLINE lineFold #-} +lineFold initial count f = go 0 initial + where go n acc | n >= count = return acc + go n acc = f acc n >>= go (n + 1) + stride :: (Storable (PixelBaseComponent a)) => Image a -> Int -> Int -> Int -> V.Vector (PixelBaseComponent a) stride Image { imageWidth = w, imageHeight = h, imageData = array } @@ -710,6 +718,7 @@ -> Int -- ^ Width in pixels -> Int -- ^ Height in pixels -> Image a +{-# INLINE generateImage #-} generateImage f w h = Image { imageWidth = w, imageHeight = h, imageData = generated } where compCount = componentCount (undefined :: a) generated = runST $ do @@ -788,10 +797,24 @@ pixelFold :: (Pixel pixel) => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = - lineFold - where pixelFolder y acc x = f acc x y $ pixelAt img x y - columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] - lineFold = foldl' columnFold initialAccumulator [0 .. h - 1] + foldl' columnFold initialAccumulator [0 .. h - 1] + where + pixelFolder y acc x = f acc x y $ pixelAt img x y + columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] + +-- | Fold over the pixel of an image with a raster scan order: +-- from top to bottom, left to right, carrying out a state +pixelFoldM :: (Pixel pixel, Monad m) + => (acc -> Int -> Int -> pixel -> m acc) -- ^ monadic mapping function + -> acc -- ^ Initial state + -> Image pixel -- ^ Image to fold over + -> m acc +{-# INLINE pixelFoldM #-} +pixelFoldM action initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = + lineFold initialAccumulator h columnFold + where + pixelFolder y acc x = action acc x y $ pixelAt img x y + columnFold lineAcc y = lineFold lineAcc w (pixelFolder y) -- | `map` equivalent for an image, working at the pixel level. -- Little example : a brightness function for an rgb image