diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,6 +1,6 @@ Name: JuicyPixels -Version: 3.1.7.1 -Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) +Version: 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.1.7.1 + Tag: v3.2 Flag Mmap Description: Enable the file loading via mmap (memory map) @@ -43,6 +43,7 @@ Codec.Picture.Png, Codec.Picture.Jpg, Codec.Picture.HDR, + Codec.Picture.Tga, Codec.Picture.Tiff, Codec.Picture.Saving, Codec.Picture.Types, diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,14 @@ -*-change-log-*- +v3.2 2014 + BREAKING CHANGES: + the Codec.Picture.Gif functions has changed interfaces. + + * Adding TGA reading. + * Adding TGA writing. + * Packeable pixel unpack. + * Returning gif with transparency (breaking Codec.Picture.Gif interface) + v3.1.7.1 August 2014 * Previous gif fix was not working withing the readImage function, only in specialized gif images. Correcting diff --git a/src/Codec/Picture.hs b/src/Codec/Picture.hs --- a/src/Codec/Picture.hs +++ b/src/Codec/Picture.hs @@ -74,6 +74,13 @@ , encodeDynamicPng , writeDynamicPng + -- ** TGA handling + , readTGA + , decodeTga + , TgaSaveable + , encodeTga + , writeTga + -- ** Tiff handling , readTiff , TiffSaveable @@ -153,6 +160,11 @@ , TiffSaveable , encodeTiff , writeTiff ) +import Codec.Picture.Tga( TgaSaveable + , decodeTga + , encodeTga + , writeTga + ) import Codec.Picture.Saving import Codec.Picture.Types import Codec.Picture.ColorQuant @@ -192,7 +204,7 @@ -- All the images of the animation are separated -- by the same delay. encodeGifAnimation :: GifDelay -> GifLooping - -> [Image PixelRGB8] -> Either String (L.ByteString) + -> [Image PixelRGB8] -> Either String L.ByteString encodeGifAnimation delay looping lst = encodeGifImages looping [(pal, delay, img) @@ -236,6 +248,7 @@ ,("GIF", decodeGif) ,("HDR", decodeHDR) ,("Tiff", decodeTiff) + ,("TGA", decodeTga) ] -- | Helper function trying to load a png file from a file on disk. @@ -252,7 +265,7 @@ -- | Helper function trying to load all the images of an animated -- gif file. -readGifImages :: FilePath -> IO (Either String [Image PixelRGB8]) +readGifImages :: FilePath -> IO (Either String [DynamicImage]) readGifImages = withImageDecoder decodeGifImages -- | Try to load a jpeg file and decompress. The colorspace is still @@ -269,6 +282,10 @@ -- RGB with floating point precision. readHDR :: FilePath -> IO (Either String DynamicImage) readHDR = withImageDecoder decodeHDR + +-- | Try to load a .tga file from disk. +readTGA :: FilePath -> IO (Either String DynamicImage) +readTGA = withImageDecoder decodeTga -- | Save an image to a '.jpg' file, will do everything it can to save an image. saveJpgImage :: Int -> FilePath -> DynamicImage -> IO () diff --git a/src/Codec/Picture/BitWriter.hs b/src/Codec/Picture/BitWriter.hs --- a/src/Codec/Picture/BitWriter.hs +++ b/src/Codec/Picture/BitWriter.hs @@ -111,7 +111,7 @@ {-# INLINE getNextBitsMSBFirst #-} getNextBitsMSBFirst :: Int -> BoolReader s Word32 -getNextBitsMSBFirst count = aux 0 count +getNextBitsMSBFirst = aux 0 where aux acc 0 = return acc aux acc n = do bit <- getNextBitMSB @@ -274,7 +274,7 @@ currWord <- readSTRef $ bwsBitAcc st currCount <- readSTRef $ bwsBitReaded st serialize d c currWord currCount - where dumpByte i = pushByte' st i + where dumpByte = pushByte' st serialize bitData bitCount currentWord count | bitCount + count == 8 = do diff --git a/src/Codec/Picture/Bitmap.hs b/src/Codec/Picture/Bitmap.hs --- a/src/Codec/Picture/Bitmap.hs +++ b/src/Codec/Picture/Bitmap.hs @@ -174,7 +174,7 @@ let lineIdx = line * w inner col | col >= w = return () inner col = do - let v = (arr `VS.unsafeIndex` (lineIdx + col)) + let v = arr `VS.unsafeIndex` (lineIdx + col) (buff `M.unsafeWrite` col) v inner (col + 1) @@ -226,9 +226,9 @@ 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)) + 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 @@ -270,7 +270,7 @@ where wi = fromIntegral w hi = fromIntegral h stArray = runST $ do - arr <- M.new (fromIntegral $ w * h * 1) + arr <- M.new . fromIntegral $ w * h forM_ [hi - 1, hi - 2 .. 0] (readLine arr) VS.unsafeFreeze arr @@ -278,9 +278,9 @@ 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 - writeIndex = wi * (hi - 1 - line) * 1 + let readIndex = (wi + stride) * line + lastIndex = wi * (hi - 1 - line + 1) + writeIndex = wi * (hi - 1 - line) inner _ writeIdx | writeIdx >= lastIndex = return () inner readIdx writeIdx = do diff --git a/src/Codec/Picture/ColorQuant.hs b/src/Codec/Picture/ColorQuant.hs --- a/src/Codec/Picture/ColorQuant.hs +++ b/src/Codec/Picture/ColorQuant.hs @@ -211,7 +211,7 @@ (Fold stepL beginL doneL) <*> (Fold stepR beginR doneR) = let step (Pair xL xR) a = Pair (stepL xL a) (stepR xR a) begin = Pair beginL beginR - done (Pair xL xR) = (doneL xL) (doneR xR) + done (Pair xL xR) = doneL xL $ doneR xR in Fold step begin done {-# INLINABLE (<*>) #-} @@ -321,9 +321,9 @@ (PixelRGBF mr mg mb) = meanColor cluster (px1, px2) = VU.partition (cond . rgbIntUnpack) $ colors cluster cond = case maxAxis $ dims cluster of - RAxis -> (\(PixelRGB8 r _ _) -> fromIntegral r < mr) - GAxis -> (\(PixelRGB8 _ g _) -> fromIntegral g < mg) - BAxis -> (\(PixelRGB8 _ _ b) -> fromIntegral b < mb) + RAxis -> \(PixelRGB8 r _ _) -> fromIntegral r < mr + GAxis -> \(PixelRGB8 _ g _) -> fromIntegral g < mg + BAxis -> \(PixelRGB8 _ _ b) -> fromIntegral b < mb rgbIntPack :: PixelRGB8 -> PackedRGB rgbIntPack (PixelRGB8 r g b) = @@ -337,7 +337,7 @@ where r = fromIntegral $ v `unsafeShiftR` (2 * 8) g = fromIntegral $ v `unsafeShiftR` 8 - b = fromIntegral $ v + b = fromIntegral v initCluster :: Image PixelRGB8 -> Cluster initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer @@ -379,4 +379,4 @@ , fromIntegral b1 - fromIntegral b2 ) nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8 -nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (\px -> dist2Px px p) ps) +nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps) diff --git a/src/Codec/Picture/Gif.hs b/src/Codec/Picture/Gif.hs --- a/src/Codec/Picture/Gif.hs +++ b/src/Codec/Picture/Gif.hs @@ -1,4 +1,6 @@ {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Module implementing GIF decoding. module Codec.Picture.Gif ( -- * Reading decodeGif @@ -19,7 +21,7 @@ ) where import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( replicateM, replicateM_ ) +import Control.Monad( replicateM, replicateM_, unless ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift ) @@ -325,9 +327,7 @@ skipSubDataBlocks :: Get () skipSubDataBlocks = do s <- fromIntegral <$> getWord8 - if s == 0 then - return () - else + unless (s == 0) $ skip s >> skipSubDataBlocks parseGifBlocks :: Get [Block] @@ -407,7 +407,7 @@ -------------------------------------------------- getPalette :: Word8 -> Get Palette getPalette bitDepth = - replicateM (size * 3) get >>= return . Image size 1 . V.fromList + Image size 1 . V.fromList <$> replicateM (size * 3) get where size = 2 ^ (fromIntegral bitDepth :: Int) putPalette :: Int -> Palette -> Put @@ -430,7 +430,7 @@ put v = do put $ gifVersion v let descr = gifScreenDescriptor v - put $ descr + put descr putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v get = do @@ -441,7 +441,7 @@ if hasGlobalMap screenDesc then getPalette $ colorTableSize screenDesc else - return $ greyPalette + return greyPalette return GifHeader { gifVersion = version @@ -498,6 +498,13 @@ substituteColors palette = pixelMap swaper where swaper n = pixelAt palette (fromIntegral n) 0 +substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 +substituteColorsWithTransparency transparent palette = pixelMap swaper where + swaper n | ix == transparent = PixelRGBA8 0 0 0 0 + | otherwise = promotePixel $ pixelAt palette ix 0 + where ix = fromIntegral n + + decodeImage :: GifImage -> Image Pixel8 decodeImage img = runST $ runBoolReader $ do outputVector <- lift . M.new $ width * height @@ -532,9 +539,10 @@ , [1, 1 + 2 .. height - 1] ] -paletteOf :: Palette -> GifImage -> Palette +paletteOf :: (ColorConvertible PixelRGB8 px) + => Image px -> GifImage -> Image px paletteOf global GifImage { imgLocalPalette = Nothing } = global -paletteOf _ GifImage { imgLocalPalette = Just p } = p +paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p getFrameDelays :: GifFile -> [GifDelay] getFrameDelays GifFile { gifImages = [] } = [] @@ -544,59 +552,110 @@ Nothing -> 0 Just e -> fromIntegral $ gceDelay e -decodeAllGifImages :: GifFile -> [Image PixelRGB8] +transparentColorOf :: Maybe GraphicControlExtension -> Int +transparentColorOf Nothing = 300 +transparentColorOf (Just ext) + | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext + | otherwise = 300 + +hasTransparency :: Maybe GraphicControlExtension -> Bool +hasTransparency Nothing = False +hasTransparency (Just control) = gceTransparentFlag control + +decodeAllGifImages :: GifFile -> [DynamicImage] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette - , gifScreenDescriptor = wholeDescriptor - } - , gifImages = (firstControl, firstImage) : rest } = map paletteApplyer $ - scanl generator initState rest - where initState = (paletteOf palette firstImage, firstControl, decodeImage firstImage) - globalWidth = fromIntegral $ screenWidth wholeDescriptor - globalHeight = fromIntegral $ screenHeight wholeDescriptor + , gifScreenDescriptor = wholeDescriptor } + , gifImages = (firstControl, firstImage) : rest } + | not (hasTransparency firstControl) = + let backImage = + generateImage (\_ _ -> backgroundColor) globalWidth globalHeight + thisPalette = paletteOf palette firstImage + initState = + (thisPalette, firstControl, substituteColors thisPalette $ decodeImage firstImage) + scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage + in + [ImageRGB8 img | (_, _, img) <- scanl scanner initState rest] - background = backgroundIndex wholeDescriptor - backgroundImage = generateImage (\_ _ -> background) globalWidth globalHeight + | otherwise = + let backImage :: Image PixelRGBA8 + backImage = + generateImage (\_ _ -> transparentBackground) globalWidth globalHeight - paletteApplyer (pal, _, img) = substituteColors pal img + thisPalette :: Image PixelRGBA8 + thisPalette = paletteOf (promoteImage palette) firstImage - generator (_, prevControl, img1) - (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = - (thisPalette, controlExt, thisImage) - where thisPalette = paletteOf palette img2 - thisImage = generateImage pixeler globalWidth globalHeight - localWidth = fromIntegral $ gDescImageWidth descriptor - localHeight = fromIntegral $ gDescImageHeight descriptor + transparentCode = transparentColorOf firstControl + decoded = + substituteColorsWithTransparency transparentCode thisPalette $ + decodeImage firstImage - left = fromIntegral $ gDescPixelsFromLeft descriptor - top = fromIntegral $ gDescPixelsFromTop descriptor + initState = (thisPalette, firstControl, decoded) + scanner = + gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in + [ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] - isPixelInLocalImage x y = - x >= left && x < left + localWidth && y >= top && y < top + localHeight + where + globalWidth = fromIntegral $ screenWidth wholeDescriptor + globalHeight = fromIntegral $ screenHeight wholeDescriptor - decoded = decodeImage img2 + transparentBackground = PixelRGBA8 r g b 0 + where PixelRGB8 r g b = backgroundColor - transparent :: Int - transparent = case controlExt of - Nothing -> 300 - Just ext -> if gceTransparentFlag ext - then fromIntegral $ gceTransparentColorIndex ext - else 300 + backgroundColor + | hasGlobalMap wholeDescriptor = + pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 + | otherwise = PixelRGB8 0 0 0 - oldImage = case gceDisposalMethod <$> prevControl of - Nothing -> img1 - Just DisposalAny -> img1 - Just DisposalDoNot -> img1 - Just DisposalRestoreBackground -> backgroundImage - Just DisposalRestorePrevious -> img1 - Just (DisposalUnknown _) -> img1 +gifAnimationApplyer :: forall px. + (Pixel px, ColorConvertible PixelRGB8 px) + => (Int, Int) -> Image px -> Image px + -> (Image px, Maybe GraphicControlExtension, Image px) + -> (Maybe GraphicControlExtension, GifImage) + -> (Image px, Maybe GraphicControlExtension, Image px) +gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage + (_, prevControl, img1) + (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = + (thisPalette, controlExt, thisImage) + where + thisPalette :: Image px + thisPalette = paletteOf globalPalette img2 - pixeler x y - | isPixelInLocalImage x y && fromIntegral val /= transparent = val - where val = pixelAt decoded (x - left) (y - top) - pixeler x y = pixelAt oldImage x y + thisImage = generateImage pixeler globalWidth globalHeight + localWidth = fromIntegral $ gDescImageWidth descriptor + localHeight = fromIntegral $ gDescImageHeight descriptor -decodeFirstGifImage :: GifFile -> Either String (Image PixelRGB8) + left = fromIntegral $ gDescPixelsFromLeft descriptor + top = fromIntegral $ gDescPixelsFromTop descriptor + + isPixelInLocalImage x y = + x >= left && x < left + localWidth && y >= top && y < top + localHeight + + decoded :: Image Pixel8 + decoded = decodeImage img2 + + transparent :: Int + transparent = case controlExt of + Nothing -> 300 + Just ext -> if gceTransparentFlag ext + then fromIntegral $ gceTransparentColorIndex ext + else 300 + + oldImage = case gceDisposalMethod <$> prevControl of + Nothing -> img1 + Just DisposalAny -> img1 + Just DisposalDoNot -> img1 + Just DisposalRestoreBackground -> backgroundImage + Just DisposalRestorePrevious -> img1 + Just (DisposalUnknown _) -> img1 + + pixeler x y + | isPixelInLocalImage x y && code /= transparent = val where + code = fromIntegral $ pixelAt decoded (x - left) (y - top) + val = pixelAt thisPalette (fromIntegral code) 0 + pixeler x y = pixelAt oldImage x y + +decodeFirstGifImage :: GifFile -> Either String DynamicImage decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = case decodeAllGifImages img { gifImages = [firstImage] } of [] -> Left "No image after decoding" @@ -609,12 +668,14 @@ -- -- * PixelRGB8 -- +-- * PixelRGBA8 +-- decodeGif :: B.ByteString -> Either String DynamicImage -decodeGif img = ImageRGB8 <$> (decode img >>= decodeFirstGifImage) +decodeGif img = decode img >>= decodeFirstGifImage -- | Transform a raw gif to a list of images, representing -- all the images of an animation. -decodeGifImages :: B.ByteString -> Either String [Image PixelRGB8] +decodeGifImages :: B.ByteString -> Either String [DynamicImage] decodeGifImages img = decodeAllGifImages <$> decode img -- | Extract a list of frame delays from a raw gif. @@ -703,7 +764,7 @@ toSerialize = [(controlExtension delay, GifImage { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img , imgLocalPalette = Just palette - , imgLzwRootSize = fromIntegral $ lzwKeySize + , imgLzwRootSize = fromIntegral lzwKeySize , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img }) | (palette, delay, img) <- imageList , let lzwKeySize = computeMinimumLzwKeySize palette 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 @@ -2,7 +2,7 @@ import Data.Word( Word8 ) import Control.Applicative( (<$>) ) -import Control.Monad( when ) +import Control.Monad( when, unless ) import Data.Bits( (.&.) ) @@ -122,9 +122,7 @@ | code == endOfInfo = return () | code == clearCode = do toOutput <- getNextCode startCodeSize - if toOutput == endOfInfo then - return () - else do + unless (toOutput == endOfInfo) $ do dataSize <- writeString outWriteIdx toOutput getNextCode startCodeSize >>= loop (outWriteIdx + dataSize) 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 @@ -15,7 +15,7 @@ import Data.Word( Word8 ) import Data.Monoid( (<>) ) import Control.Applicative( pure, (<$>), (<*>) ) -import Control.Monad( when, foldM, foldM_, forM, forM_ ) +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 @@ -166,7 +166,7 @@ -- * PixelRGBF -- decodeHDR :: B.ByteString -> Either String DynamicImage -decodeHDR str = runST $ runExceptT $ do +decodeHDR str = runST $ runExceptT $ case runGet decodeHeader $ L.fromChunks [str] of Left err -> throwE err Right rez -> @@ -187,11 +187,11 @@ letter <- getChar8 space <- getChar8 - when (not $ isSign sign && isAxisLetter letter && space == ' ') - (fail "Invalid radiance size declaration") + 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')) + getChar8 >>= numDec (acc * 10 + ord c - ord '0') numDec acc _ | sign == '-' = pure $ negate acc | otherwise = pure acc @@ -371,7 +371,7 @@ 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 -> do + False -> pushRun n prev at >>= runLength 1 0 val (idx + 1) @@ -379,7 +379,7 @@ val <- vec `M.unsafeRead` idx if val /= prev then runLength 0 (n + 1) val (idx + 1) at - else do + else pushData (idx - 1) (n - 1) at >>= runLength (2 :: Int) 0 val (idx + 1) @@ -464,7 +464,7 @@ (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff - pure $ RadianceHeader + pure RadianceHeader { radianceInfos = [] , radianceFormat = FormatRGBE , radianceHeight = h @@ -473,7 +473,7 @@ } -decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s (PixelRGBF)) +decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) decodeRadiancePicture hdr = do let width = abs $ radianceWidth hdr height = abs $ radianceHeight hdr diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -144,7 +144,7 @@ val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) (img `M.unsafeWrite` idx) val0 - (img `M.unsafeWrite` (idx + (3 * 1))) val1 + (img `M.unsafeWrite` (idx + (3 ))) val1 (img `M.unsafeWrite` (idx + (3 * 2))) val2 (img `M.unsafeWrite` (idx + (3 * 3))) val3 (img `M.unsafeWrite` (idx + (3 * 4))) val4 @@ -189,8 +189,8 @@ (img `M.unsafeWrite` idx) v0 (img `M.unsafeWrite` (idx + 3)) v0 - (img `M.unsafeWrite` (idx + 6 * 1)) v1 - (img `M.unsafeWrite` (idx + 6 * 1 + 3)) v1 + (img `M.unsafeWrite` (idx + 6 )) v1 + (img `M.unsafeWrite` (idx + 6 + 3)) v1 (img `M.unsafeWrite` (idx + 6 * 2)) v2 (img `M.unsafeWrite` (idx + 6 * 2 + 3)) v2 @@ -350,7 +350,7 @@ if idx >= V.length (dcDecoderTables s) then s else let neu = dcDecoderTables s // [(idx, tree)] in - s { dcDecoderTables = neu `seq` neu } + s { dcDecoderTables = neu } where idx = fromIntegral $ huffmanTableDest spec AcComponent -> modify $ \s -> @@ -412,7 +412,7 @@ acTree = acHuffmanTree comp quantId = fromIntegral . quantizationTableDest $ jpgComponents frame !! compIdx - qTable = quants V.! (min 3 quantId) + qTable = quants V.! min 3 quantId xd = blockMcuX comp yd = blockMcuY comp (subX, subY) = subSampling comp @@ -730,8 +730,8 @@ let blockY = my * sizeY + subY blockX = mx * sizeX + subX prev_dc <- dc_table `M.unsafeRead` comp - (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= - encodeMacroBlock table workData zigzaged prev_dc) + (dc_coeff, neo_block) <- extractor comp blockX blockY >>= + encodeMacroBlock table workData zigzaged prev_dc (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff serializeMacroBlock writeState dc ac neo_block 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 @@ -1,7 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) @@ -27,7 +26,7 @@ ) where import Control.Applicative( (<$>) ) -import Control.Monad( forM_, foldM_, when ) +import Control.Monad( forM_, foldM_, when, void ) import Control.Monad.ST( ST, runST ) import Data.Binary( Binary( get) ) @@ -151,7 +150,7 @@ b' = fromIntegral valB average = fromIntegral ((a' + b') `div` (2 :: Word16)) writeVal = byte + average - (thisLine `M.unsafeWrite` idx) $ writeVal + (thisLine `M.unsafeWrite` idx) writeVal inner (idx + 1) $ readIdx + 1 filterPaeth !previousLine !thisLine = inner beginZeroes @@ -297,7 +296,7 @@ lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) writeIdx = destSampleIndex + sample - (arr `M.unsafeWrite` writeIdx) $ fullValue + (arr `M.unsafeWrite` writeIdx) fullValue -- | Transform a scanline to a bunch of bytes. Bytes are then packed -- into pixels at a further step. @@ -317,7 +316,7 @@ -> B.ByteString -> ST s () scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = - pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 >> return () + void $ pngFiltering (unpacker (1,1) (0, 0)) strideInfo (byteWidth, imgHeight) str 0 where byteWidth = byteSizeOfBitLength depth sampleCount imgWidth strideInfo | depth < 8 = 1 | otherwise = sampleCount * (depth `div` 8) @@ -327,7 +326,7 @@ adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) -> B.ByteString -> ST s () adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = - foldM_ (\i f -> f i) 0 subImages >> return () + void $ foldM_ (\i f -> f i) 0 subImages where Adam7MatrixInfo { adam7StartingRow = startRows , adam7RowIncrement = rowIncrement , adam7StartingCol = startCols diff --git a/src/Codec/Picture/Png/Type.hs b/src/Codec/Picture/Png/Type.hs --- a/src/Codec/Picture/Png/Type.hs +++ b/src/Codec/Picture/Png/Type.hs @@ -10,6 +10,7 @@ , iDATSignature , iENDSignature , tRNSSignature + , gammaSignature -- * Low level types , ChunkSignature , PngRawImage( .. ) @@ -292,6 +293,9 @@ tRNSSignature :: ChunkSignature tRNSSignature = signature "tRNS" + +gammaSignature :: ChunkSignature +gammaSignature = signature "gAMA" instance Binary PngImageType where put PngGreyscale = putWord8 0 diff --git a/src/Codec/Picture/Saving.hs b/src/Codec/Picture/Saving.hs --- a/src/Codec/Picture/Saving.hs +++ b/src/Codec/Picture/Saving.hs @@ -27,7 +27,7 @@ componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 toStandardDef :: Image PixelRGBF -> Image PixelRGB8 -toStandardDef img = pixelMap pixelConverter img +toStandardDef = pixelMap pixelConverter where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b where r = componentToLDR rf g = componentToLDR gf diff --git a/src/Codec/Picture/Tga.hs b/src/Codec/Picture/Tga.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Picture/Tga.hs @@ -0,0 +1,503 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE BangPatterns #-} +-- | Module implementing function to read and write +-- Targa (*.tga) files. +module Codec.Picture.Tga( decodeTga + , TgaSaveable + , encodeTga + , writeTga + ) where + +import Control.Monad.ST( ST, runST ) +import Control.Applicative( (<$>), (<*>), pure ) +import Data.Bits( (.&.) + , (.|.) + , bit + , testBit + , setBit + , unsafeShiftL + , unsafeShiftR ) +import Data.Monoid( mempty ) +import Data.Word( Word8, Word16 ) +import Data.Binary( Binary( .. ), encode ) +import Data.Binary.Get( Get + , getByteString + , getWord8 + , getWord16le + ) +import Data.Binary.Put( putWord8 + , putWord16le + , putByteString + ) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb +import qualified Data.ByteString.Unsafe as U +import qualified Data.Vector.Storable.Mutable as M + +import Codec.Picture.Types +import Codec.Picture.InternalHelper +import Codec.Picture.VectorByteConversion + +data TgaColorMapType + = ColorMapWithoutTable + | ColorMapWithTable + | ColorMapUnknown Word8 + +instance Binary TgaColorMapType where + get = do + v <- getWord8 + return $ case v of + 0 -> ColorMapWithoutTable + 1 -> ColorMapWithTable + n -> ColorMapUnknown n + + put v = case v of + ColorMapWithoutTable -> putWord8 0 + ColorMapWithTable -> putWord8 1 + (ColorMapUnknown vv) -> putWord8 vv + +data TgaImageType + = ImageTypeNoData Bool + | ImageTypeColorMapped Bool + | ImageTypeTrueColor Bool + | ImageTypeMonochrome Bool + +isRleEncoded :: TgaImageType -> Bool +isRleEncoded v = case v of + ImageTypeNoData yn -> yn + ImageTypeColorMapped yn -> yn + ImageTypeTrueColor yn -> yn + ImageTypeMonochrome yn -> yn + +imageTypeOfCode :: Monad m => Word8 -> m TgaImageType +imageTypeOfCode v = case v .&. 3 of + 0 -> return $ ImageTypeNoData isEncoded + 1 -> return $ ImageTypeColorMapped isEncoded + 2 -> return $ ImageTypeTrueColor isEncoded + 3 -> return $ ImageTypeMonochrome isEncoded + _ -> fail $ "Unknown TGA image type " ++ show v + where + isEncoded = testBit v 3 + +codeOfImageType :: TgaImageType -> Word8 +codeOfImageType v = case v of + ImageTypeNoData encoded -> setVal 0 encoded + ImageTypeColorMapped encoded -> setVal 1 encoded + ImageTypeTrueColor encoded -> setVal 2 encoded + ImageTypeMonochrome encoded -> setVal 3 encoded + where + setVal vv True = setBit vv 3 + setVal vv False = vv + +instance Binary TgaImageType where + get = getWord8 >>= imageTypeOfCode + put = putWord8 . codeOfImageType + +data TgaImageDescription = TgaImageDescription + { _tgaIdXOrigin :: Bool + , _tgaIdYOrigin :: Bool + , _tgaIdAttributeBits :: Word8 + } + +instance Binary TgaImageDescription where + put desc = putWord8 $ xOrig .|. yOrig .|. attr + where + xOrig | _tgaIdXOrigin desc = bit 4 + | otherwise = 0 + + yOrig | not $ _tgaIdYOrigin desc = bit 5 + | otherwise = 0 + + attr = _tgaIdAttributeBits desc .&. 0xF + + get = toDescr <$> getWord8 where + toDescr v = TgaImageDescription + { _tgaIdXOrigin = testBit v 4 + , _tgaIdYOrigin = not $ testBit v 5 + , _tgaIdAttributeBits = v .&. 0xF + } + +data TgaHeader = TgaHeader + { _tgaHdrIdLength :: {-# UNPACK #-} !Word8 + , _tgaHdrColorMapType :: !TgaColorMapType + , _tgaHdrImageType :: !TgaImageType + , _tgaHdrMapStart :: {-# UNPACK #-} !Word16 + , _tgaHdrMapLength :: {-# UNPACK #-} !Word16 + , _tgaHdrMapDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrXOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrYOffset :: {-# UNPACK #-} !Word16 + , _tgaHdrWidth :: {-# UNPACK #-} !Word16 + , _tgaHdrHeight :: {-# UNPACK #-} !Word16 + , _tgaHdrPixelDepth :: {-# UNPACK #-} !Word8 + , _tgaHdrImageDescription :: {-# UNPACK #-} !TgaImageDescription + } + +instance Binary TgaHeader where + get = TgaHeader + <$> g8 <*> get <*> get <*> g16 <*> g16 <*> g8 + <*> g16 <*> g16 <*> g16 <*> g16 <*> g8 <*> get + where g16 = getWord16le + g8 = getWord8 + + put v = do + let p8 = putWord8 + p16 = putWord16le + p8 $ _tgaHdrIdLength v + put $ _tgaHdrColorMapType v + put $ _tgaHdrImageType v + + p16 $ _tgaHdrMapStart v + p16 $ _tgaHdrMapLength v + p8 $ _tgaHdrMapDepth v + p16 $ _tgaHdrXOffset v + p16 $ _tgaHdrYOffset v + p16 $ _tgaHdrWidth v + p16 $ _tgaHdrHeight v + p8 $ _tgaHdrPixelDepth v + put $ _tgaHdrImageDescription v + + +data TgaFile = TgaFile + { _tgaFileHeader :: !TgaHeader + , _tgaFileId :: !B.ByteString + , _tgaPalette :: !B.ByteString + , _tgaFileRest :: !B.ByteString + } + +getPalette :: TgaHeader -> Get B.ByteString +getPalette hdr | _tgaHdrMapLength hdr <= 0 = return mempty +getPalette hdr = getByteString $ bytePerPixel * pixelCount + where + bytePerPixel = fromIntegral $ _tgaHdrMapDepth hdr `div` 8 + pixelCount = fromIntegral $ _tgaHdrMapLength hdr + +instance Binary TgaFile where + get = do + hdr <- get + validateTga hdr + fileId <- getByteString . fromIntegral $ _tgaHdrIdLength hdr + palette <- getPalette hdr + rest <- getRemainingBytes + + return TgaFile { + _tgaFileHeader = hdr + , _tgaFileId = fileId + , _tgaPalette = palette + , _tgaFileRest = rest + } + + put file = do + put $ _tgaFileHeader file + putByteString $ _tgaFileId file + putByteString $ _tgaPalette file + putByteString $ _tgaFileRest file + +data Depth8 = Depth8 +data Depth15 = Depth15 +data Depth24 = Depth24 +data Depth32 = Depth32 + +class (Pixel (Unpacked a)) => TGAPixel a where + type Unpacked a + packedByteSize :: a -> Int + tgaUnpack :: a -> B.ByteString -> Int -> Unpacked a + +instance TGAPixel Depth8 where + type Unpacked Depth8 = Pixel8 + packedByteSize _ = 1 + tgaUnpack _ = U.unsafeIndex + +instance TGAPixel Depth15 where + type Unpacked Depth15 = PixelRGBA8 + packedByteSize _ = 2 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + v0 = U.unsafeIndex str ix + v1 = U.unsafeIndex str $ ix + 1 + r = (v1 .&. 0x7c) `unsafeShiftL` 1; + g = ((v1 .&. 0x03) `unsafeShiftL` 6) .|. ((v0 .&. 0xe0) `unsafeShiftR` 2); + b = (v0 .&. 0x1f) `unsafeShiftL` 3 + a = 255 -- v1 .&. 0x80 + +instance TGAPixel Depth24 where + type Unpacked Depth24 = PixelRGB8 + packedByteSize _ = 3 + tgaUnpack _ str ix = PixelRGB8 r g b + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + +instance TGAPixel Depth32 where + type Unpacked Depth32 = PixelRGBA8 + packedByteSize _ = 4 + tgaUnpack _ str ix = PixelRGBA8 r g b a + where + b = U.unsafeIndex str ix + g = U.unsafeIndex str (ix + 1) + r = U.unsafeIndex str (ix + 2) + a = 255 - U.unsafeIndex str (ix + 3) + +prepareUnpacker :: TgaFile + -> (forall tgapx. (TGAPixel tgapx) => tgapx -> TgaFile -> Image (Unpacked tgapx)) + -> Either String DynamicImage +prepareUnpacker file f = + let hdr = _tgaFileHeader file + flipper :: (Pixel px) => Image px -> Image px + flipper = flipImage $ _tgaHdrImageDescription hdr + in + case _tgaHdrPixelDepth hdr of + 8 -> pure . ImageY8 . flipper $ f Depth8 file + 16 -> pure . ImageRGBA8 . flipper $ f Depth15 file + 24 -> pure . ImageRGB8 . flipper $ f Depth24 file + 32 -> pure . ImageRGBA8 . flipper $ f Depth32 file + n -> fail $ "Invalid bit depth (" ++ show n ++ ")" + +applyPalette :: (Pixel px) + => (Image px -> DynamicImage) -> Image px + -> DynamicImage + -> Either String DynamicImage +applyPalette f palette (ImageY8 img) = + pure . f $ pixelMap (\v -> pixelAt palette (fromIntegral v) 0) img +applyPalette _ _ _ = + fail "Bad colorspace for image" + +unparse :: TgaFile -> Either String DynamicImage +unparse file = + let hdr = _tgaFileHeader file + imageType = _tgaHdrImageType hdr + + unpacker :: forall tgapx. (TGAPixel tgapx) + => tgapx -> TgaFile -> Image (Unpacked tgapx) + unpacker | isRleEncoded imageType = unpackRLETga + | otherwise = unpackUncompressedTga + + decodedPalette = unparse file + { _tgaFileHeader = hdr + { _tgaHdrHeight = 1 + , _tgaHdrWidth = _tgaHdrMapLength hdr + , _tgaHdrPixelDepth = _tgaHdrMapDepth hdr + , _tgaHdrImageType = ImageTypeTrueColor False + } + , _tgaFileRest = _tgaPalette file + } + in + case imageType of + ImageTypeNoData _ -> fail "No data detected in TGA file" + ImageTypeTrueColor _ -> + prepareUnpacker file unpacker + ImageTypeMonochrome _ -> + prepareUnpacker file unpacker + ImageTypeColorMapped _ -> + case decodedPalette of + Left str -> Left str + Right (ImageY8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageY8 img + Right (ImageRGB8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageRGB8 img + Right (ImageRGBA8 img) -> + prepareUnpacker file unpacker >>= applyPalette ImageRGBA8 img + Right _ -> fail "Unknown pixel type" + +writeRun :: (Pixel px) + => M.STVector s (PixelBaseComponent px) -> Int -> px -> Int + -> ST s Int +writeRun imgData localMaxi px = run + where + writeDelta = componentCount px + run writeIndex + | writeIndex >= localMaxi = return writeIndex + run writeIndex = do + unsafeWritePixel imgData writeIndex px + run $ writeIndex + writeDelta + +copyData :: forall tgapx s + . (TGAPixel tgapx) + => tgapx + -> M.STVector s (PixelBaseComponent (Unpacked tgapx)) + -> B.ByteString + -> Int -> Int + -> Int -> Int + -> ST s (Int, Int) +copyData tgapx imgData readData maxi maxRead = go + where + readDelta = packedByteSize tgapx + writeDelta = componentCount (undefined :: Unpacked tgapx) + + go writeIndex readIndex + | writeIndex >= maxi || + readIndex >= maxRead = return (writeIndex, readIndex) + go writeIndex readIndex = do + let px = tgaUnpack tgapx readData readIndex :: Unpacked tgapx + unsafeWritePixel imgData writeIndex px + go (writeIndex + writeDelta) (readIndex + readDelta) + +unpackUncompressedTga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackUncompressedTga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + _ <- copyData tga imgData readData maxi maxRead 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + +isRleChunk :: Word8 -> Bool +isRleChunk v = testBit v 7 + +runLength :: Word8 -> Int +runLength v = fromIntegral (v .&. 0x7F) + 1 + +unpackRLETga :: forall tgapx + . (TGAPixel tgapx) + => tgapx -- ^ Type witness + -> TgaFile + -> Image (Unpacked tgapx) +unpackRLETga tga file = runST $ do + img <- MutableImage width height <$> M.new maxi + let imgData = mutableImageData img + + go writeIndex readIndex + | writeIndex >= maxi = return () + | readIndex >= maxRead = return () + go writeIndex readIndex = do + let code = U.unsafeIndex readData readIndex + copyMax = min maxi $ writeIndex + runLength code * compCount + + if isRleChunk code then do + let px = tgaUnpack tga readData (readIndex + 1) :: Unpacked tgapx + lastWriteIndex <- writeRun imgData copyMax px writeIndex + go lastWriteIndex $ readIndex + 1 + readDelta + + else do + (newWrite, newRead) <- + copyData tga imgData readData copyMax maxRead + writeIndex (readIndex + 1) + go newWrite newRead + + go 0 0 + unsafeFreezeImage img + + where + hdr = _tgaFileHeader file + width = fromIntegral $ _tgaHdrWidth hdr + height = fromIntegral $ _tgaHdrHeight hdr + readData = _tgaFileRest file + compCount = componentCount (undefined :: Unpacked tgapx) + maxi = width * height * compCount + maxRead = B.length readData + readDelta = packedByteSize tga + +flipImage :: (Pixel px) + => TgaImageDescription -> Image px -> Image px +flipImage desc img + | xFlip && yFlip = + generateImage (\x y -> pixelAt img (wMax - x) (hMax - y)) w h + | xFlip = + generateImage (\x y -> pixelAt img (wMax - x) y) w h + | yFlip = + generateImage (\x y -> pixelAt img x (hMax - y)) w h + | otherwise = img + where + xFlip = _tgaIdXOrigin desc + yFlip = _tgaIdYOrigin desc + w = imageWidth img + h = imageHeight img + + !wMax = w - 1 + !hMax = h - 1 + +validateTga :: (Monad m) => TgaHeader -> m () +validateTga hdr + | _tgaHdrWidth hdr <= 0 = fail "Width is null or negative" + | _tgaHdrHeight hdr <= 0 = fail "Height is null or negative" +validateTga _ = return () + +-- | Transform a raw tga image to an image, without modifying +-- the underlying pixel type. +-- +-- This function can output the following pixel types: +-- +-- * PixelY8 +-- +-- * PixelRGB8 +-- +-- * PixelRGBA8 +-- +decodeTga :: B.ByteString -> Either String DynamicImage +decodeTga byte = runGetStrict get byte >>= unparse + +-- | This typeclass determine if a pixel can be saved in the +-- TGA format. +class TgaSaveable a where + tgaDataOfImage :: Image a -> B.ByteString + tgaPixelDepthOfImage :: Image a -> Word8 + tgaTypeOfImage :: Image a -> TgaImageType + +instance TgaSaveable Pixel8 where + tgaDataOfImage = toByteString . imageData + tgaPixelDepthOfImage _ = 8 + tgaTypeOfImage _ = ImageTypeMonochrome False + +instance TgaSaveable PixelRGB8 where + tgaPixelDepthOfImage _ = 24 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgb + where + flipRgb (PixelRGB8 r g b) = PixelRGB8 b g r + +instance TgaSaveable PixelRGBA8 where + tgaPixelDepthOfImage _ = 32 + tgaTypeOfImage _ = ImageTypeTrueColor False + tgaDataOfImage = toByteString . imageData . pixelMap flipRgba + where + flipRgba (PixelRGBA8 r g b a) = PixelRGBA8 b g r a + +-- | Helper function to directly write an image a tga on disk. +writeTga :: (TgaSaveable pixel) => FilePath -> Image pixel -> IO () +writeTga path img = Lb.writeFile path $ encodeTga img + +-- | Transform a compatible image to a raw bytestring +-- representing a Targa file. +encodeTga :: (TgaSaveable px) => Image px -> Lb.ByteString +encodeTga img = encode file + where + file = TgaFile + { _tgaFileHeader = TgaHeader + { _tgaHdrIdLength = 0 + , _tgaHdrColorMapType = ColorMapWithoutTable + , _tgaHdrImageType = tgaTypeOfImage img + , _tgaHdrMapStart = 0 + , _tgaHdrMapLength = 0 + , _tgaHdrMapDepth = 0 + , _tgaHdrXOffset = 0 + , _tgaHdrYOffset = 0 + , _tgaHdrWidth = fromIntegral $ imageWidth img + , _tgaHdrHeight = fromIntegral $ imageHeight img + , _tgaHdrPixelDepth = tgaPixelDepthOfImage img + , _tgaHdrImageDescription = TgaImageDescription + { _tgaIdXOrigin = False + , _tgaIdYOrigin = False + , _tgaIdAttributeBits = 0 + } + } + , _tgaFileId = mempty + , _tgaPalette = mempty + , _tgaFileRest = tgaDataOfImage img + } + diff --git a/src/Codec/Picture/Tiff.hs b/src/Codec/Picture/Tiff.hs --- a/src/Codec/Picture/Tiff.hs +++ b/src/Codec/Picture/Tiff.hs @@ -27,11 +27,11 @@ module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where import Control.Applicative( (<$>), (<*>), pure ) -import Control.Monad( when, replicateM, foldM_ ) +import Control.Monad( when, replicateM, foldM_, unless ) import Control.Monad.ST( ST, runST ) import Control.Monad.Writer.Strict( execWriter, tell, Writer ) import Data.Int( Int8 ) -import Data.Word( Word8, Word16 ) +import Data.Word( Word8, Word16, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.Binary( Binary( .. ) ) import Data.Binary.Get( Get @@ -51,7 +51,6 @@ import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M -import Data.Word( Word32 ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as Lb import qualified Data.ByteString.Unsafe as BU @@ -614,7 +613,7 @@ choice -- data - | 0 <= v = do + | 0 <= v = copyByteString str outVec stride writeIdx (fromIntegral $ i + 1, fromIntegral v + 1) >>= loop (i + 2 + fromIntegral v) @@ -1055,7 +1054,7 @@ $ tiffExtraSample nfo let subSampling = tiffYCbCrSubsampling nfo - when (not $ V.null subSampling) $ + unless (V.null subSampling) $ ifdShorts TagYCbCrSubsampling subSampling putByteString rawData @@ -1139,8 +1138,7 @@ | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = pure . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo -unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } - | otherwise = do +unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) case img of ImageY8 i -> pure . ImageY8 $ pixelMap (maxBound -) i @@ -1149,7 +1147,7 @@ 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" + _ -> fail "Unsupported color type used with colorspace MonochromeWhite0" unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst @@ -1168,7 +1166,7 @@ let toWord16 v = fromIntegral $ v `unsafeShiftR` 16 img = gatherStrips (0 :: Word32) file nfo :: Image Pixel32 in - pure . ImageY16 $ pixelMap (toWord16) img + pure . ImageY16 $ pixelMap toWord16 img | 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 = @@ -1308,7 +1306,7 @@ where intSampleCount = componentCount (undefined :: px) sampleCount = fromIntegral intSampleCount - sampleType = (undefined :: PixelBaseComponent px) + sampleType = undefined :: PixelBaseComponent px pixelData = imageData img rawPixelData = toByteString pixelData @@ -1328,7 +1326,7 @@ , tiffWidth = width , tiffHeight = height , tiffColorspace = colorSpaceOfPixel (undefined :: px) - , tiffSampleCount = fromIntegral $ sampleCount + , tiffSampleCount = fromIntegral sampleCount , tiffRowPerStrip = fromIntegral $ imageHeight img , tiffPlaneConfiguration = PlanarConfigContig , tiffSampleFormat = [TiffSampleUint] diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -85,8 +85,9 @@ -- * Packeable writing (unsafe but faster) , PackeablePixel( .. ) , fillImageWith - , unsafeWritePixelBetweenAt + , readPackedPixelAt , writePackedPixelAt + , unsafeWritePixelBetweenAt ) where import Control.Monad( foldM, liftM, ap ) @@ -95,7 +96,7 @@ import Control.Monad.Primitive ( PrimMonad, PrimState ) import Foreign.ForeignPtr( castForeignPtr ) import Foreign.Storable ( Storable ) -import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.) ) +import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) ) import Data.Word( Word8, Word16, Word32, Word64 ) import Data.List( foldl' ) import Data.Vector.Storable ( (!) ) @@ -928,7 +929,7 @@ -- of an image or a pixel class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where -- | Compute the luminance part of a pixel - computeLuma :: a -> (PixelBaseComponent a) + computeLuma :: a -> PixelBaseComponent a -- | Extract a luma plane out of an image. This -- method is in the typeclass to help performant @@ -1776,11 +1777,11 @@ rY = fix 0.29900 gY = fix 0.58700 bY = fix 0.11400 - rCb = (- fix 0.16874) - gCb = (- fix 0.33126) + rCb = - fix 0.16874 + gCb = - fix 0.33126 bCb = fix 0.5 - gCr = (- fix 0.41869) - bCr = (- fix 0.08131) + gCr = - fix 0.41869 + bCr = - fix 0.08131 newData = runST $ do block <- M.new $ maxi * 3 @@ -1952,7 +1953,7 @@ m = (ig - kInt) `div` ik y = (ib - kInt) `div` ik - clamp = fromIntegral . (max 0) + clamp = fromIntegral . max 0 instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) @@ -2090,29 +2091,42 @@ -- to a primitive. packPixel :: a -> PackedRepresentation a + -- | Inverse transformation, to speed up + -- reading + unpackPixel :: PackedRepresentation a -> a + instance PackeablePixel Pixel8 where type PackedRepresentation Pixel8 = Pixel8 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel Pixel16 where type PackedRepresentation Pixel16 = Pixel16 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel Pixel32 where type PackedRepresentation Pixel32 = Pixel32 packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel PixelF where type PackedRepresentation PixelF = PixelF packPixel = id {-# INLINE packPixel #-} + unpackPixel = id + {-# INLINE unpackPixel #-} instance PackeablePixel PixelRGBA8 where type PackedRepresentation PixelRGBA8 = Word32 + {-# INLINE packPixel #-} packPixel (PixelRGBA8 r g b a) = (fi r `unsafeShiftL` (0 * bitCount)) .|. (fi g `unsafeShiftL` (1 * bitCount)) .|. @@ -2121,8 +2135,19 @@ where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelRGBA8 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + instance PackeablePixel PixelRGBA16 where type PackedRepresentation PixelRGBA16 = Word64 + {-# INLINE packPixel #-} packPixel (PixelRGBA16 r g b a) = (fi r `unsafeShiftL` (0 * bitCount)) .|. (fi g `unsafeShiftL` (1 * bitCount)) .|. @@ -2131,8 +2156,19 @@ where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelRGBA16 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelCMYK8 where type PackedRepresentation PixelCMYK8 = Word32 + {-# INLINE packPixel #-} packPixel (PixelCMYK8 c m y k) = (fi c `unsafeShiftL` (0 * bitCount)) .|. (fi m `unsafeShiftL` (1 * bitCount)) .|. @@ -2141,8 +2177,19 @@ where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelCMYK8 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + instance PackeablePixel PixelCMYK16 where type PackedRepresentation PixelCMYK16 = Word64 + {-# INLINE packPixel #-} packPixel (PixelCMYK16 c m y k) = (fi c `unsafeShiftL` (0 * bitCount)) .|. (fi m `unsafeShiftL` (1 * bitCount)) .|. @@ -2151,22 +2198,46 @@ where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = + PixelCMYK16 (low w) + (low $ w `unsafeShiftR` bitCount) + (low $ w `unsafeShiftR` (2 * bitCount)) + (low $ w `unsafeShiftR` (3 * bitCount)) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelYA16 where type PackedRepresentation PixelYA16 = Word32 + {-# INLINE packPixel #-} packPixel (PixelYA16 y a) = (fi y `unsafeShiftL` (0 * bitCount)) .|. (fi a `unsafeShiftL` (1 * bitCount)) where fi = fromIntegral bitCount = 16 + {-# INLINE unpackPixel #-} + unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount) + where + low v = fromIntegral (v .&. 0xFFFF) + bitCount = 16 + instance PackeablePixel PixelYA8 where type PackedRepresentation PixelYA8 = Word16 + {-# INLINE packPixel #-} packPixel (PixelYA8 y a) = (fi y `unsafeShiftL` (0 * bitCount)) .|. (fi a `unsafeShiftL` (1 * bitCount)) where fi = fromIntegral bitCount = 8 + {-# INLINE unpackPixel #-} + unpackPixel w = PixelYA8 (low w) (low $ w `unsafeShiftR` bitCount) + where + low v = fromIntegral (v .&. 0xFF) + bitCount = 8 + -- | This function will fill an image with a simple packeable -- pixel. It will be faster than any unsafeWritePixel. fillImageWith :: ( Pixel px, PackeablePixel px @@ -2200,6 +2271,28 @@ !packedPtr = castForeignPtr ptr !converted = M.unsafeFromForeignPtr packedPtr s s2 + +-- | Read a packeable pixel from an image. Equivalent to +-- unsafeReadPixel +readPackedPixelAt :: forall m px. + ( Pixel px, PackeablePixel px + , M.Storable (PackedRepresentation px) + , PrimMonad m + ) + => MutableImage (PrimState m) px -- ^ Image to read from + -> Int -- ^ Index in (PixelBaseComponent px) count + -> m px +{-# INLINE readPackedPixelAt #-} +readPackedPixelAt img idx = do + unpacked <- M.unsafeRead converted (idx `div` compCount) + return $ unpackPixel unpacked + where + !compCount = componentCount (undefined :: px) + (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img + !packedPtr = castForeignPtr ptr + !converted = + M.unsafeFromForeignPtr packedPtr s s2 + -- | Write a packeable pixel into an image. equivalent to unsafeWritePixel. writePackedPixelAt :: ( Pixel px, PackeablePixel px 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 @@ -15,7 +15,7 @@ import Codec.Picture.Types blitVector :: Vector Word8 -> Int -> Int -> B.ByteString -blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize +blitVector vec atIndex = S.PS ptr (offset + atIndex) where (ptr, offset, _length) = unsafeToForeignPtr vec toByteString :: forall a. (Storable a) => Vector a -> B.ByteString