JuicyPixels-3.2.8/docimages/0000755000000000000000000000000012516654722014127 5ustar0000000000000000JuicyPixels-3.2.8/src/0000755000000000000000000000000012507725344012762 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/0000755000000000000000000000000012763046173013777 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/0000755000000000000000000000000012763046173015412 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/Gif/0000755000000000000000000000000012763010461016106 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/Jpg/0000755000000000000000000000000012763046173016132 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/Metadata/0000755000000000000000000000000012763010461017121 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/Png/0000755000000000000000000000000012763046173016136 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture/Tiff/0000755000000000000000000000000012763010461016271 5ustar0000000000000000JuicyPixels-3.2.8/src/Codec/Picture.hs0000644000000000000000000004335012763046173015753 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleInstances #-} -- | Main module for image import/export into various image formats. -- -- To use the library without thinking about it, look after 'decodeImage' and -- 'readImage'. -- -- Generally, the @read*@ functions read the images from a file and try to decode -- it, and the @decode*@ functions try to decode a bytestring. -- -- For an easy image writing use the 'saveBmpImage', 'saveJpgImage' & 'savePngImage' -- functions module Codec.Picture ( -- * Generic functions readImage , readImageWithMetadata , decodeImage , decodeImageWithMetadata , decodeImageWithPaletteAndMetadata , pixelMap , generateImage , generateFoldImage , withImage , palettedToTrueColor -- * RGB helper functions , convertRGB8 , convertRGBA8 -- * Lens compatibility , Traversal , imagePixels , imageIPixels -- * Generic image writing , saveBmpImage , saveJpgImage , saveGifImage , savePngImage , saveTiffImage , saveRadianceImage -- * Specific image format functions -- ** Bitmap handling , BmpEncodable , writeBitmap , encodeBitmap , readBitmap , decodeBitmap , encodeDynamicBitmap , writeDynamicBitmap -- ** Gif handling , readGif , readGifImages , decodeGif , decodeGifImages , encodeGifImage , writeGifImage , encodeGifImageWithPalette , writeGifImageWithPalette , encodeColorReducedGifImage , writeColorReducedGifImage , encodeGifImages , writeGifImages -- *** Gif animation , GifDelay , GifLooping( .. ) , encodeGifAnimation , writeGifAnimation -- ** Jpeg handling , readJpeg , decodeJpeg , encodeJpeg , encodeJpegAtQuality -- ** Png handling , PngSavable( .. ) , readPng , decodePng , writePng , encodePalettedPng , encodeDynamicPng , writeDynamicPng -- ** TGA handling , readTGA , decodeTga , TgaSaveable , encodeTga , writeTga -- ** Tiff handling , readTiff , TiffSaveable , decodeTiff , encodeTiff , writeTiff -- ** HDR (Radiance/RGBE) handling , readHDR , decodeHDR , encodeHDR , writeHDR -- ** Color Quantization , PaletteCreationMethod(..) , PaletteOptions(..) , palettize -- * Image types and pixel types -- ** Image , Image( .. ) , DynamicImage( .. ) , Palette -- ** Pixels , Pixel( .. ) -- $graph , Pixel8 , Pixel16 , PixelF , PixelYA8( .. ) , PixelYA16( .. ) , PixelRGB8( .. ) , PixelRGB16( .. ) , PixelRGBF( .. ) , PixelRGBA8( .. ) , PixelRGBA16( .. ) , PixelYCbCr8( .. ) , PixelCMYK8( .. ) , PixelCMYK16( .. ) -- * Foreign unsafe import , imageFromUnsafePtr ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) #endif import Control.Arrow( first ) import Data.Bits( unsafeShiftR ) import Control.DeepSeq( NFData, deepseq ) import qualified Control.Exception as Exc ( catch, IOException ) import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.Bitmap( BmpEncodable , decodeBitmap , decodeBitmapWithPaletteAndMetadata , writeBitmap, encodeBitmap , encodeDynamicBitmap, writeDynamicBitmap ) import Codec.Picture.Jpg( decodeJpeg , decodeJpegWithMetadata , encodeJpeg , encodeJpegAtQuality ) import Codec.Picture.Png( PngSavable( .. ) , decodePng , decodePngWithPaletteAndMetadata , writePng , encodeDynamicPng , encodePalettedPng , writeDynamicPng ) import Codec.Picture.Gif( GifDelay , GifLooping( .. ) , decodeGif , decodeGifWithPaletteAndMetadata , decodeGifImages , encodeGifImage , encodeGifImageWithPalette , encodeGifImages , writeGifImage , writeGifImageWithPalette , writeGifImages ) import Codec.Picture.HDR( decodeHDR , decodeHDRWithMetadata , encodeHDR , writeHDR ) import Codec.Picture.Tiff( decodeTiff , decodeTiffWithPaletteAndMetadata , TiffSaveable , encodeTiff , writeTiff ) import Codec.Picture.Tga( TgaSaveable , decodeTga , decodeTgaWithPaletteAndMetadata , encodeTga , writeTga ) import Codec.Picture.Saving import Codec.Picture.Types import Codec.Picture.ColorQuant import Codec.Picture.VectorByteConversion( imageFromUnsafePtr ) -- import System.IO ( withFile, IOMode(ReadMode) ) #ifdef WITH_MMAP_BYTESTRING import System.IO.MMap ( mmapFileByteString ) #endif import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Vector.Storable as VS -- | Return the first Right thing, accumulating error eitherLoad :: c -> [(String, c -> Either String b)] -> Either String b eitherLoad v = inner "" where inner errAcc [] = Left $ "Cannot load file\n" ++ errAcc inner errAcc ((hdr, f) : rest) = case f v of Left err -> inner (errAcc ++ hdr ++ " " ++ err ++ "\n") rest Right rez -> Right rez -- | Encode a full color image to a gif by applying a color quantization -- algorithm on it. encodeColorReducedGifImage :: Image PixelRGB8 -> Either String L.ByteString encodeColorReducedGifImage img = encodeGifImageWithPalette indexed pal where (indexed, pal) = palettize defaultPaletteOptions img -- | Write a full color image to a gif by applying a color quantization -- algorithm on it. writeColorReducedGifImage :: FilePath -> Image PixelRGB8 -> Either String (IO ()) writeColorReducedGifImage path img = L.writeFile path <$> encodeColorReducedGifImage img -- | Helper function to create a gif animation. -- All the images of the animation are separated -- by the same delay. encodeGifAnimation :: GifDelay -> GifLooping -> [Image PixelRGB8] -> Either String L.ByteString encodeGifAnimation delay looping lst = encodeGifImages looping [(pal, delay, img) | (img, pal) <- palettize defaultPaletteOptions <$> lst] -- | Helper function to write a gif animation on disk. -- See encodeGifAnimation writeGifAnimation :: FilePath -> GifDelay -> GifLooping -> [Image PixelRGB8] -> Either String (IO ()) writeGifAnimation path delay looping img = L.writeFile path <$> encodeGifAnimation delay looping img withImageDecoder :: (NFData a) => (B.ByteString -> Either String a) -> FilePath -> IO (Either String a) withImageDecoder decoder path = Exc.catch doit (\e -> return . Left $ show (e :: Exc.IOException)) where doit = force . decoder <$> get #ifdef WITH_MMAP_BYTESTRING get = mmapFileByteString path Nothing #else get = B.readFile path #endif -- force appeared in deepseq 1.3, Haskell Platform -- provides 1.1 force x = x `deepseq` x -- | Load an image file without even thinking about it, it does everything -- as 'decodeImage' readImage :: FilePath -> IO (Either String DynamicImage) readImage = withImageDecoder decodeImage -- | Equivalent to 'readImage' but also providing metadatas. readImageWithMetadata :: FilePath -> IO (Either String (DynamicImage, Metadatas)) readImageWithMetadata = withImageDecoder decodeImageWithMetadata -- | 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 succeeds, it will return -- the decoded image in it's own colorspace. decodeImage :: B.ByteString -> Either String DynamicImage decodeImage = fmap fst . decodeImageWithMetadata class Decimable px1 px2 where decimateBitDepth :: Image px1 -> Image px2 decimateWord16 :: ( Pixel px1, Pixel px2 , PixelBaseComponent px1 ~ Pixel16 , PixelBaseComponent px2 ~ Pixel8 ) => Image px1 -> Image px2 decimateWord16 (Image w h da) = Image w h $ VS.map (\v -> fromIntegral $ v `unsafeShiftR` 8) da decimateFloat :: ( Pixel px1, Pixel px2 , PixelBaseComponent px1 ~ PixelF , PixelBaseComponent px2 ~ Pixel8 ) => Image px1 -> Image px2 decimateFloat (Image w h da) = Image w h $ VS.map (floor . (255*) . max 0 . min 1) da instance Decimable Pixel16 Pixel8 where decimateBitDepth = decimateWord16 instance Decimable PixelYA16 PixelYA8 where decimateBitDepth = decimateWord16 instance Decimable PixelRGB16 PixelRGB8 where decimateBitDepth = decimateWord16 instance Decimable PixelRGBA16 PixelRGBA8 where decimateBitDepth = decimateWord16 instance Decimable PixelCMYK16 PixelCMYK8 where decimateBitDepth = decimateWord16 instance Decimable PixelF Pixel8 where decimateBitDepth = decimateFloat instance Decimable PixelRGBF PixelRGB8 where decimateBitDepth = decimateFloat -- | Convert by any mean possible a dynamic image to an image -- in RGBA. The process can lose precision while converting from -- 16bits pixels or Floating point pixels. convertRGBA8 :: DynamicImage -> Image PixelRGBA8 convertRGBA8 dynImage = case dynImage of ImageY8 img -> promoteImage img ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYA8 img -> promoteImage img ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) ImageRGB8 img -> promoteImage img ImageRGB16 img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) ImageRGBF img -> promoteImage (decimateBitDepth img :: Image PixelRGB8) ImageRGBA8 img -> promoteImage img ImageRGBA16 img -> decimateBitDepth img ImageYCbCr8 img -> promoteImage (convertImage img :: Image PixelRGB8) ImageCMYK8 img -> promoteImage (convertImage img :: Image PixelRGB8) ImageCMYK16 img -> promoteImage (convertImage (decimateBitDepth img :: Image PixelCMYK8) :: Image PixelRGB8) -- | Convert by any mean possible a dynamic image to an image -- in RGB. The process can lose precision while converting from -- 16bits pixels or Floating point pixels. Any alpha layer will -- be dropped convertRGB8 :: DynamicImage -> Image PixelRGB8 convertRGB8 dynImage = case dynImage of ImageY8 img -> promoteImage img ImageY16 img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYF img -> promoteImage (decimateBitDepth img :: Image Pixel8) ImageYA8 img -> promoteImage img ImageYA16 img -> promoteImage (decimateBitDepth img :: Image PixelYA8) ImageRGB8 img -> img ImageRGB16 img -> decimateBitDepth img ImageRGBF img -> decimateBitDepth img :: Image PixelRGB8 ImageRGBA8 img -> dropAlphaLayer img ImageRGBA16 img -> dropAlphaLayer (decimateBitDepth img :: Image PixelRGBA8) ImageYCbCr8 img -> convertImage img ImageCMYK8 img -> convertImage img ImageCMYK16 img -> convertImage (decimateBitDepth img :: Image PixelCMYK8) -- | Equivalent to 'decodeImage', but also provide potential metadatas -- present in the given file and the palettes if the format provides them. decodeImageWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeImageWithPaletteAndMetadata str = eitherLoad str [ ("Jpeg", fmap (first TrueColorImage) . decodeJpegWithMetadata) , ("PNG", decodePngWithPaletteAndMetadata) , ("Bitmap", decodeBitmapWithPaletteAndMetadata) , ("GIF", decodeGifWithPaletteAndMetadata) , ("HDR", fmap (first TrueColorImage) . decodeHDRWithMetadata) , ("Tiff", decodeTiffWithPaletteAndMetadata) , ("TGA", decodeTgaWithPaletteAndMetadata) ] -- | Equivalent to 'decodeImage', but also provide potential metadatas -- present in the given file. decodeImageWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeImageWithMetadata = fmap (first palettedToTrueColor) . decodeImageWithPaletteAndMetadata -- | Helper function trying to load a png file from a file on disk. readPng :: FilePath -> IO (Either String DynamicImage) readPng = withImageDecoder decodePng -- | Helper function trying to load a gif file from a file on disk. readGif :: FilePath -> IO (Either String DynamicImage) readGif = withImageDecoder decodeGif -- | Helper function trying to load tiff file from a file on disk. readTiff :: FilePath -> IO (Either String DynamicImage) readTiff = withImageDecoder decodeTiff -- | Helper function trying to load all the images of an animated -- gif file. readGifImages :: FilePath -> IO (Either String [DynamicImage]) readGifImages = withImageDecoder decodeGifImages -- | 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'. readJpeg :: FilePath -> IO (Either String DynamicImage) readJpeg = withImageDecoder decodeJpeg -- | Try to load a .bmp file. The colorspace would be RGB, RGBA or Y. readBitmap :: FilePath -> IO (Either String DynamicImage) readBitmap = withImageDecoder decodeBitmap -- | Try to load a .pic file. The colorspace can only be -- 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 () saveJpgImage quality path img = L.writeFile path $ imageToJpg quality img -- | Save an image to a '.gif' file, will do everything it can to save it. saveGifImage :: FilePath -> DynamicImage -> Either String (IO ()) saveGifImage path img = L.writeFile path <$> imageToGif img -- | Save an image to a '.tiff' file, will do everything it can to save an image. saveTiffImage :: FilePath -> DynamicImage -> IO () saveTiffImage path img = L.writeFile path $ imageToTiff img -- | Save an image to a '.hdr' file, will do everything it can to save an image. saveRadianceImage :: FilePath -> DynamicImage -> IO () saveRadianceImage path = L.writeFile path . imageToRadiance -- | Save an image to a '.png' file, will do everything it can to save an image. -- For example, a simple transcoder to png -- -- > transcodeToPng :: FilePath -> FilePath -> IO () -- > transcodeToPng pathIn pathOut = do -- > eitherImg <- readImage pathIn -- > case eitherImg of -- > Left _ -> return () -- > Right img -> savePngImage pathOut img -- savePngImage :: FilePath -> DynamicImage -> IO () savePngImage path img = L.writeFile path $ imageToPng img -- | Save an image to a '.bmp' file, will do everything it can to save an image. saveBmpImage :: FilePath -> DynamicImage -> IO () saveBmpImage path img = L.writeFile path $ imageToBitmap img JuicyPixels-3.2.8/src/Codec/Picture/Bitmap.hs0000644000000000000000000005005112763046173017163 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} -- | Modules used for Bitmap file (.bmp) file loading and writing module Codec.Picture.Bitmap( -- * Functions writeBitmap , encodeBitmap , encodeBitmapWithMetadata , decodeBitmap , decodeBitmapWithMetadata , decodeBitmapWithPaletteAndMetadata , encodeDynamicBitmap , encodeBitmapWithPaletteAndMetadata , writeDynamicBitmap -- * Accepted format in output , BmpEncodable( ) ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) import Control.Applicative( (<$>) ) #endif import Control.Arrow( first ) import Control.Monad( replicateM, when, foldM_, forM_ ) import Control.Monad.ST ( ST, runST ) import Data.Maybe( fromMaybe ) import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Data.Binary( Binary( .. ) ) import Data.Binary.Put( Put , runPut , putWord16le , putWord32le , putByteString ) import Data.Binary.Get( Get , getWord8 , getWord16le , getWord32le , getWord32be , bytesRead , skip ) import Data.Int( Int32 ) import Data.Word( Word32, Word16, Word8 ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.VectorByteConversion import qualified Codec.Picture.Metadata as Met import Codec.Picture.Metadata ( Metadatas ) data BmpHeader = BmpHeader { magicIdentifier :: !Word16 , fileSize :: !Word32 -- ^ in bytes , reserved1 :: !Word16 , reserved2 :: !Word16 , dataOffset :: !Word32 } bitmapMagicIdentifier :: Word16 bitmapMagicIdentifier = 0x4D42 instance Binary BmpHeader where put hdr = do putWord16le $ magicIdentifier hdr putWord32le $ fileSize hdr putWord16le $ reserved1 hdr putWord16le $ reserved2 hdr putWord32le $ dataOffset hdr get = do ident <- getWord16le when (ident /= bitmapMagicIdentifier) (fail "Invalid Bitmap magic identifier") fsize <- getWord32le r1 <- getWord16le r2 <- getWord16le offset <- getWord32le return BmpHeader { magicIdentifier = ident , fileSize = fsize , reserved1 = r1 , reserved2 = r2 , dataOffset = offset } data BmpInfoHeader = BmpInfoHeader { size :: !Word32 -- Header size in bytes , width :: !Int32 , height :: !Int32 , planes :: !Word16 -- Number of colour planes , bitPerPixel :: !Word16 , bitmapCompression :: !Word32 , byteImageSize :: !Word32 , xResolution :: !Int32 -- ^ Pixels per meter , yResolution :: !Int32 -- ^ Pixels per meter , colorCount :: !Word32 , importantColours :: !Word32 } deriving Show sizeofBmpHeader, sizeofBmpInfo :: Word32 sizeofBmpHeader = 2 + 4 + 2 + 2 + 4 sizeofBmpInfo = 3 * 4 + 2 * 2 + 6 * 4 instance Binary BmpInfoHeader where put hdr = do putWord32le $ size hdr putWord32le . fromIntegral $ width hdr putWord32le . fromIntegral $ height hdr putWord16le $ planes hdr putWord16le $ bitPerPixel hdr putWord32le $ bitmapCompression hdr putWord32le $ byteImageSize hdr putWord32le . fromIntegral $ xResolution hdr putWord32le . fromIntegral $ yResolution hdr putWord32le $ colorCount hdr putWord32le $ importantColours hdr get = do readSize <- getWord32le readWidth <- fromIntegral <$> getWord32le readHeight <- fromIntegral <$> getWord32le readPlanes <- getWord16le readBitPerPixel <- getWord16le readBitmapCompression <- getWord32le readByteImageSize <- getWord32le readXResolution <- fromIntegral <$> getWord32le readYResolution <- fromIntegral <$> getWord32le readColorCount <- getWord32le readImportantColours <- getWord32le return BmpInfoHeader { size = readSize, width = readWidth, height = readHeight, planes = readPlanes, bitPerPixel = readBitPerPixel, bitmapCompression = readBitmapCompression, byteImageSize = readByteImageSize, xResolution = readXResolution, yResolution = readYResolution, colorCount = readColorCount, importantColours = readImportantColours } newtype BmpPalette = BmpPalette [(Word8, Word8, Word8, Word8)] putPalette :: BmpPalette -> Put putPalette (BmpPalette p) = mapM_ (\(r, g, b, a) -> put r >> put g >> put b >> put a) p -- | All the instance of this class can be written as a bitmap file -- using this library. class BmpEncodable pixel where bitsPerPixel :: pixel -> Int bmpEncode :: Image pixel -> Put defaultPalette :: pixel -> BmpPalette defaultPalette _ = BmpPalette [] stridePut :: M.STVector s Word8 -> Int -> Int -> ST s () {-# INLINE stridePut #-} stridePut vec = inner where inner _ 0 = return () inner ix n = do (vec `M.unsafeWrite` ix) 0 inner (ix + 1) (n - 1) instance BmpEncodable Pixel8 where defaultPalette _ = BmpPalette [(x,x,x, 255) | x <- [0 .. 255]] bitsPerPixel _ = 8 bmpEncode (Image {imageWidth = w, imageHeight = h, imageData = arr}) = forM_ [h - 1, h - 2 .. 0] $ \l -> putVector $ runST $ encodeLine l where stride = fromIntegral $ linePadding 8 w 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 let lineIdx = line * w inner col | col >= w = return () inner col = do let v = arr `VS.unsafeIndex` (lineIdx + col) (buff `M.unsafeWrite` col) v inner (col + 1) inner 0 stridePut buff w stride VS.unsafeFreeze buff instance BmpEncodable PixelRGBA8 where 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 :: 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) (buff `M.unsafeWrite` writeIdx) b (buff `M.unsafeWrite` (writeIdx + 1)) g (buff `M.unsafeWrite` (writeIdx + 2)) r (buff `M.unsafeWrite` (writeIdx + 3)) a 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 :: 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 decodeImageRGBA8 :: BmpInfoHeader -> (Int, Int, Int, Int) -> B.ByteString -> Image PixelRGBA8 decodeImageRGBA8 (BmpInfoHeader { width = w, height = h }) (posR, posG, posB, posA) str = Image wi hi stArray where wi = fromIntegral w hi = abs $ fromIntegral h stArray = runST $ do arr <- M.new (fromIntegral $ w * abs h * 4) if h > 0 then foldM_ (readLine arr) 0 [0 .. hi - 1] else foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr stride = linePadding 32 wi -- will be 0 readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int readLine arr readIndex line = inner readIndex writeIndex where lastIndex = wi * (hi - 1 - line + 1) * 4 writeIndex = wi * (hi - 1 - line) * 4 inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride inner readIdx writeIdx = do -- 32-bit BMP pixels are BGRA (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + posR)) (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + posG)) (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` (readIdx + posB)) (arr `M.unsafeWrite` (writeIdx + 3)) (str `B.index` (readIdx + posA)) inner (readIdx + 4) (writeIdx + 4) decodeImageRGB8 :: BmpInfoHeader -> B.ByteString -> Image PixelRGB8 decodeImageRGB8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where wi = fromIntegral w hi = abs $ fromIntegral h stArray = runST $ do arr <- M.new (fromIntegral $ w * abs h * 3) if h > 0 then foldM_ (readLine arr) 0 [0 .. hi - 1] else foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr stride = linePadding 24 wi readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int readLine arr readIndex line = inner readIndex writeIndex where lastIndex = wi * (hi - 1 - line + 1) * 3 writeIndex = wi * (hi - 1 - line) * 3 inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride inner readIdx writeIdx = do (arr `M.unsafeWrite` writeIdx ) (str `B.index` (readIdx + 2)) (arr `M.unsafeWrite` (writeIdx + 1)) (str `B.index` (readIdx + 1)) (arr `M.unsafeWrite` (writeIdx + 2)) (str `B.index` readIdx) inner (readIdx + 3) (writeIdx + 3) decodeImageY8 :: BmpInfoHeader -> B.ByteString -> Image Pixel8 decodeImageY8 (BmpInfoHeader { width = w, height = h }) str = Image wi hi stArray where wi = fromIntegral w hi = abs $ fromIntegral h stArray = runST $ do arr <- M.new . fromIntegral $ w * abs h if h > 0 then foldM_ (readLine arr) 0 [0 .. hi - 1] else foldM_ (readLine arr) 0 [hi - 1, hi - 2 .. 0] VS.unsafeFreeze arr stride = linePadding 8 wi readLine :: forall s. M.MVector s Word8 -> Int -> Int -> ST s Int readLine arr readIndex line = inner readIndex writeIndex where lastIndex = wi * (hi - 1 - line + 1) writeIndex = wi * (hi - 1 - line) inner readIdx writeIdx | writeIdx >= lastIndex = return $ readIdx + stride inner readIdx writeIdx = do (arr `M.unsafeWrite` writeIdx) (str `B.index` readIdx) inner (readIdx + 1) (writeIdx + 1) pixelGet :: Get [Word8] pixelGet = do b <- getWord8 g <- getWord8 r <- getWord8 _ <- getWord8 return $ [r, g, b] metadataOfHeader :: BmpInfoHeader -> Metadatas metadataOfHeader hdr = Met.simpleMetadata Met.SourceBitmap (width hdr) (abs $ height hdr) dpiX dpiY where dpiX = Met.dotsPerMeterToDotPerInch . fromIntegral $ xResolution hdr dpiY = Met.dotsPerMeterToDotPerInch . fromIntegral $ yResolution hdr -- | Try to decode a bitmap image. -- Right now this function can output the following image: -- -- - 'ImageY8' -- -- - 'ImageRGB8' -- -- - 'ImageRGBA8' -- decodeBitmap :: B.ByteString -> Either String DynamicImage decodeBitmap = fmap fst . decodeBitmapWithMetadata -- | Same as 'decodeBitmap' but also extracts metadata. decodeBitmapWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeBitmapWithMetadata byte = first palettedToTrueColor <$> decodeBitmapWithPaletteAndMetadata byte -- | Same as 'decodeBitmap' but also extracts metadata and provide separated palette. decodeBitmapWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeBitmapWithPaletteAndMetadata str = flip runGetStrict str $ do hdr <- get :: Get BmpHeader bmpHeader <- get :: Get BmpInfoHeader readed <- bytesRead when (readed > fromIntegral (dataOffset hdr)) (fail "Invalid bmp image, data in header") when (width bmpHeader <= 0) (fail $ "Invalid bmp width, " ++ show (width bmpHeader)) when (height bmpHeader == 0) (fail $ "Invalid bmp height (0) ") let bpp = fromIntegral $ bitPerPixel bmpHeader :: Int paletteColorCount | colorCount bmpHeader == 0 = 2 ^ bpp | otherwise = fromIntegral $ colorCount bmpHeader getData = do readed' <- bytesRead skip . fromIntegral $ dataOffset hdr - fromIntegral readed' getRemainingBytes addMetadata i = (i, metadataOfHeader bmpHeader) case (bitPerPixel bmpHeader, planes bmpHeader, bitmapCompression bmpHeader) of (32, 1, 0) -> do rest <- getData return . addMetadata . TrueColorImage . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (2, 1, 0, 3) rest -- (2, 1, 0, 3) means BGRA pixel order (32, 1, 3) -> do posRed <- getBitfield posGreen <- getBitfield posBlue <- getBitfield posAlpha <- getBitfield rest <- getData return . addMetadata . TrueColorImage . ImageRGBA8 $ decodeImageRGBA8 bmpHeader (posRed, posGreen, posBlue, posAlpha) rest (24, 1, 0) -> do rest <- getData return . addMetadata . TrueColorImage . ImageRGB8 $ decodeImageRGB8 bmpHeader rest ( 8, 1, 0) -> do table <- replicateM paletteColorCount pixelGet rest <- getData let palette = Palette' { _paletteSize = paletteColorCount , _paletteData = VS.fromListN (paletteColorCount * 3) $ concat table } return . addMetadata $ PalettedRGB8 (decodeImageY8 bmpHeader rest) palette a -> fail $ "Can't handle BMP file " ++ show a getBitfield :: Get Int getBitfield = do w32 <- getWord32be case w32 of 0xFF000000 -> return 0 0x00FF0000 -> return 1 0x0000FF00 -> return 2 0x000000FF -> return 3 _ -> fail $ "Codec.Picture.Bitmap.getBitfield: unsupported bitfield of " ++ show w32 -- | Write an image in a file use the bitmap format. writeBitmap :: (BmpEncodable pixel) => FilePath -> Image pixel -> IO () writeBitmap filename img = L.writeFile filename $ encodeBitmap img linePadding :: Int -> Int -> Int linePadding bpp imgWidth = (4 - (bytesPerLine `mod` 4)) `mod` 4 where bytesPerLine = imgWidth * (fromIntegral bpp `div` 8) -- | Encode an image into a bytestring in .bmp format ready to be written -- on disk. encodeBitmap :: forall pixel. (BmpEncodable pixel) => Image pixel -> L.ByteString encodeBitmap = encodeBitmapWithPalette (defaultPalette (undefined :: pixel)) -- | Equivalent to 'encodeBitmap' but also store -- the following metadatas: -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' -- encodeBitmapWithMetadata :: forall pixel. BmpEncodable pixel => Metadatas -> Image pixel -> L.ByteString encodeBitmapWithMetadata metas = encodeBitmapWithPaletteAndMetadata metas (defaultPalette (undefined :: pixel)) -- | Write a dynamic image in a .bmp image file if possible. -- The same restriction as 'encodeDynamicBitmap' apply. writeDynamicBitmap :: FilePath -> DynamicImage -> IO (Either String Bool) writeDynamicBitmap path img = case encodeDynamicBitmap img of Left err -> return $ Left err Right b -> L.writeFile path b >> return (Right True) -- | Encode a dynamic image in BMP if possible, supported images are: -- -- - 'ImageY8' -- -- - 'ImageRGB8' -- -- - 'ImageRGBA8' -- encodeDynamicBitmap :: DynamicImage -> Either String L.ByteString encodeDynamicBitmap (ImageRGB8 img) = Right $ encodeBitmap img encodeDynamicBitmap (ImageRGBA8 img) = Right $ encodeBitmap img encodeDynamicBitmap (ImageY8 img) = Right $ encodeBitmap img encodeDynamicBitmap _ = Left "Unsupported image format for bitmap export" extractDpiOfMetadata :: Metadatas -> (Word32, Word32) extractDpiOfMetadata metas = (fetch Met.DpiX, fetch Met.DpiY) where fetch k = fromMaybe 0 $ fromIntegral . Met.dotPerInchToDotsPerMeter <$> Met.lookup k metas -- | Convert an image to a bytestring ready to be serialized. encodeBitmapWithPalette :: forall pixel. (BmpEncodable pixel) => BmpPalette -> Image pixel -> L.ByteString encodeBitmapWithPalette = encodeBitmapWithPaletteAndMetadata mempty -- | Equivalent to 'encodeBitmapWithPalette' but also store -- the following metadatas: -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' -- encodeBitmapWithPaletteAndMetadata :: forall pixel. (BmpEncodable pixel) => Metadatas -> BmpPalette -> Image pixel -> L.ByteString encodeBitmapWithPaletteAndMetadata metas pal@(BmpPalette palette) img = runPut $ put hdr >> put info >> putPalette pal >> bmpEncode img where imgWidth = fromIntegral $ imageWidth img imgHeight = fromIntegral $ imageHeight img (dpiX, dpiY) = extractDpiOfMetadata metas paletteSize = fromIntegral $ length palette bpp = bitsPerPixel (undefined :: pixel) padding = linePadding bpp imgWidth imagePixelSize = fromIntegral $ (imgWidth * div bpp 8 + padding) * imgHeight hdr = BmpHeader { magicIdentifier = bitmapMagicIdentifier, fileSize = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize + imagePixelSize, reserved1 = 0, reserved2 = 0, dataOffset = sizeofBmpHeader + sizeofBmpInfo + 4 * paletteSize } info = BmpInfoHeader { size = sizeofBmpInfo, width = fromIntegral imgWidth, height = fromIntegral imgHeight, planes = 1, bitPerPixel = fromIntegral bpp, bitmapCompression = 0, -- no compression byteImageSize = imagePixelSize, xResolution = fromIntegral dpiX, yResolution = fromIntegral dpiY, colorCount = 0, importantColours = paletteSize } {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/Gif.hs0000644000000000000000000007447612763046173016475 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -- | Module implementing GIF decoding. module Codec.Picture.Gif ( -- * Reading decodeGif , decodeGifWithMetadata , decodeGifWithPaletteAndMetadata , decodeGifImages , getDelaysGifImages -- * Writing , GifDelay , GifLooping( .. ) , encodeGifImage , encodeGifImageWithPalette , encodeGifImages , writeGifImage , writeGifImageWithPalette , writeGifImages , greyPalette ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<*>), (<$>) ) #endif import Control.Arrow( first ) import Control.Monad( replicateM, replicateM_, unless ) import Control.Monad.ST( runST ) import Control.Monad.Trans.Class( lift ) import Data.Bits( (.&.), (.|.) , unsafeShiftR , unsafeShiftL , testBit, setBit ) import Data.Word( Word8, Word16 ) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M import Data.Binary( Binary(..), encode ) import Data.Binary.Get( Get , getWord8 , getWord16le , getByteString , bytesRead , skip ) import Data.Binary.Put( Put , putWord8 , putWord16le , putByteString ) import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.Metadata( Metadatas , SourceFormat( SourceGif ) , basicMetadata ) import Codec.Picture.Gif.LZW import Codec.Picture.Gif.LZWEncoding import Codec.Picture.BitWriter -- | Delay to wait before showing the next Gif image. -- The delay is expressed in 100th of seconds. type GifDelay = Int -- | Help to control the behaviour of GIF animation looping. data GifLooping = -- | The animation will stop once the end is reached LoopingNever -- | The animation will restart once the end is reached | LoopingForever -- | The animation will repeat n times before stoping | LoopingRepeat Word16 {- ::= Header * Trailer ::= Logical Screen Descriptor [Global Color Table] ::= | ::= [Graphic Control Extension] ::= | Plain Text Extension ::= Image Descriptor [Local Color Table] Image Data ::= Application Extension | Comment Extension -} -------------------------------------------------- ---- GifVersion -------------------------------------------------- data GifVersion = GIF87a | GIF89a gif87aSignature, gif89aSignature :: B.ByteString gif87aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF87a" gif89aSignature = B.pack $ map (fromIntegral . fromEnum) "GIF89a" instance Binary GifVersion where put GIF87a = putByteString gif87aSignature put GIF89a = putByteString gif89aSignature get = do sig <- getByteString (B.length gif87aSignature) case (sig == gif87aSignature, sig == gif89aSignature) of (True, _) -> pure GIF87a (_ , True) -> pure GIF89a _ -> fail $ "Invalid Gif signature : " ++ (toEnum . fromEnum <$> B.unpack sig) -------------------------------------------------- ---- LogicalScreenDescriptor -------------------------------------------------- -- | Section 18 of spec-gif89a data LogicalScreenDescriptor = LogicalScreenDescriptor { -- | Stored on 16 bits screenWidth :: !Word16 -- | Stored on 16 bits , screenHeight :: !Word16 -- | Stored on 8 bits , backgroundIndex :: !Word8 -- | Stored on 1 bit , hasGlobalMap :: !Bool -- | Stored on 3 bits , colorResolution :: !Word8 -- | Stored on 1 bit , isColorTableSorted :: !Bool -- | Stored on 3 bits , colorTableSize :: !Word8 } instance Binary LogicalScreenDescriptor where put v = do putWord16le $ screenWidth v putWord16le $ screenHeight v let globalMapField | hasGlobalMap v = 0x80 | otherwise = 0 colorTableSortedField | isColorTableSorted v = 0x08 | otherwise = 0 tableSizeField = (colorTableSize v - 1) .&. 7 colorResolutionField = ((colorResolution v - 1) .&. 7) `unsafeShiftL` 5 packedField = globalMapField .|. colorTableSortedField .|. tableSizeField .|. colorResolutionField putWord8 packedField putWord8 0 -- aspect ratio putWord8 $ backgroundIndex v get = do w <- getWord16le h <- getWord16le packedField <- getWord8 backgroundColorIndex <- getWord8 _aspectRatio <- getWord8 return LogicalScreenDescriptor { screenWidth = w , screenHeight = h , hasGlobalMap = packedField `testBit` 7 , colorResolution = (packedField `unsafeShiftR` 5) .&. 0x7 + 1 , isColorTableSorted = packedField `testBit` 3 , colorTableSize = (packedField .&. 0x7) + 1 , backgroundIndex = backgroundColorIndex } -------------------------------------------------- ---- ImageDescriptor -------------------------------------------------- -- | Section 20 of spec-gif89a data ImageDescriptor = ImageDescriptor { gDescPixelsFromLeft :: !Word16 , gDescPixelsFromTop :: !Word16 , gDescImageWidth :: !Word16 , gDescImageHeight :: !Word16 , gDescHasLocalMap :: !Bool , gDescIsInterlaced :: !Bool , gDescIsImgDescriptorSorted :: !Bool , gDescLocalColorTableSize :: !Word8 } imageSeparator, extensionIntroducer, gifTrailer :: Word8 imageSeparator = 0x2C extensionIntroducer = 0x21 gifTrailer = 0x3B graphicControlLabel, commentLabel, plainTextLabel, applicationLabel :: Word8 plainTextLabel = 0x01 graphicControlLabel = 0xF9 commentLabel = 0xFE applicationLabel = 0xFF parseDataBlocks :: Get B.ByteString parseDataBlocks = B.concat <$> (getWord8 >>= aux) where aux 0 = pure [] aux size = (:) <$> getByteString (fromIntegral size) <*> (getWord8 >>= aux) putDataBlocks :: B.ByteString -> Put putDataBlocks wholeString = putSlices wholeString >> putWord8 0 where putSlices str | B.length str == 0 = pure () | B.length str > 0xFF = let (before, after) = B.splitAt 0xFF str in putWord8 0xFF >> putByteString before >> putSlices after putSlices str = putWord8 (fromIntegral $ B.length str) >> putByteString str data DisposalMethod = DisposalAny | DisposalDoNot | DisposalRestoreBackground | DisposalRestorePrevious | DisposalUnknown Word8 disposalMethodOfCode :: Word8 -> DisposalMethod disposalMethodOfCode v = case v of 0 -> DisposalAny 1 -> DisposalDoNot 2 -> DisposalRestoreBackground 3 -> DisposalRestorePrevious n -> DisposalUnknown n codeOfDisposalMethod :: DisposalMethod -> Word8 codeOfDisposalMethod v = case v of DisposalAny -> 0 DisposalDoNot -> 1 DisposalRestoreBackground -> 2 DisposalRestorePrevious -> 3 DisposalUnknown n -> n data GraphicControlExtension = GraphicControlExtension { gceDisposalMethod :: !DisposalMethod -- ^ Stored on 3 bits , gceUserInputFlag :: !Bool , gceTransparentFlag :: !Bool , gceDelay :: !Word16 , gceTransparentColorIndex :: !Word8 } instance Binary GraphicControlExtension where put v = do putWord8 extensionIntroducer putWord8 graphicControlLabel putWord8 0x4 -- size let disposalCode = codeOfDisposalMethod $ gceDisposalMethod v disposalField = (disposalCode .&. 0x7) `unsafeShiftL` 2 userInputField | gceUserInputFlag v = 0 `setBit` 1 | otherwise = 0 transparentField | gceTransparentFlag v = 0 `setBit` 0 | otherwise = 0 packedFields = disposalField .|. userInputField .|. transparentField putWord8 packedFields putWord16le $ gceDelay v putWord8 $ gceTransparentColorIndex v putWord8 0 -- blockTerminator get = do -- due to missing lookahead {-_extensionLabel <- getWord8-} _size <- getWord8 packedFields <- getWord8 delay <- getWord16le idx <- getWord8 _blockTerminator <- getWord8 return GraphicControlExtension { gceDisposalMethod = disposalMethodOfCode $ (packedFields `unsafeShiftR` 2) .&. 0x07 , gceUserInputFlag = packedFields `testBit` 1 , gceTransparentFlag = packedFields `testBit` 0 , gceDelay = delay , gceTransparentColorIndex = idx } data GifImage = GifImage { imgDescriptor :: !ImageDescriptor , imgLocalPalette :: !(Maybe Palette) , imgLzwRootSize :: !Word8 , imgData :: B.ByteString } instance Binary GifImage where put img = do let descriptor = imgDescriptor img put descriptor case ( imgLocalPalette img , gDescHasLocalMap $ imgDescriptor img) of (Nothing, _) -> return () (Just _, False) -> return () (Just p, True) -> putPalette (fromIntegral $ gDescLocalColorTableSize descriptor) p putWord8 $ imgLzwRootSize img putDataBlocks $ imgData img get = do desc <- get let hasLocalColorTable = gDescHasLocalMap desc palette <- if hasLocalColorTable then Just <$> getPalette (gDescLocalColorTableSize desc) else pure Nothing GifImage desc palette <$> getWord8 <*> parseDataBlocks data Block = BlockImage GifImage | BlockGraphicControl GraphicControlExtension skipSubDataBlocks :: Get () skipSubDataBlocks = do s <- fromIntegral <$> getWord8 unless (s == 0) $ skip s >> skipSubDataBlocks parseGifBlocks :: Get [Block] parseGifBlocks = getWord8 >>= blockParse where blockParse v | v == gifTrailer = pure [] | v == imageSeparator = (:) <$> (BlockImage <$> get) <*> parseGifBlocks | v == extensionIntroducer = getWord8 >>= extensionParse blockParse v = do readPosition <- bytesRead fail ("Unrecognized gif block " ++ show v ++ " @" ++ show readPosition) extensionParse code | code == graphicControlLabel = (:) <$> (BlockGraphicControl <$> get) <*> parseGifBlocks | code == commentLabel = skipSubDataBlocks >> parseGifBlocks | code `elem` [plainTextLabel, applicationLabel] = fromIntegral <$> getWord8 >>= skip >> skipSubDataBlocks >> parseGifBlocks | otherwise = parseDataBlocks >> parseGifBlocks instance Binary ImageDescriptor where put v = do putWord8 imageSeparator putWord16le $ gDescPixelsFromLeft v putWord16le $ gDescPixelsFromTop v putWord16le $ gDescImageWidth v putWord16le $ gDescImageHeight v let localMapField | gDescHasLocalMap v = 0 `setBit` 7 | otherwise = 0 isInterlacedField | gDescIsInterlaced v = 0 `setBit` 6 | otherwise = 0 isImageDescriptorSorted | gDescIsImgDescriptorSorted v = 0 `setBit` 5 | otherwise = 0 localSize = gDescLocalColorTableSize v tableSizeField | localSize > 0 = (localSize - 1) .&. 0x7 | otherwise = 0 packedFields = localMapField .|. isInterlacedField .|. isImageDescriptorSorted .|. tableSizeField putWord8 packedFields get = do -- due to missing lookahead {-_imageSeparator <- getWord8-} imgLeftPos <- getWord16le imgTopPos <- getWord16le imgWidth <- getWord16le imgHeight <- getWord16le packedFields <- getWord8 let tableSize = packedFields .&. 0x7 return ImageDescriptor { gDescPixelsFromLeft = imgLeftPos , gDescPixelsFromTop = imgTopPos , gDescImageWidth = imgWidth , gDescImageHeight = imgHeight , gDescHasLocalMap = packedFields `testBit` 7 , gDescIsInterlaced = packedFields `testBit` 6 , gDescIsImgDescriptorSorted = packedFields `testBit` 5 , gDescLocalColorTableSize = if tableSize > 0 then tableSize + 1 else 0 } -------------------------------------------------- ---- Palette -------------------------------------------------- getPalette :: Word8 -> Get Palette getPalette bitDepth = Image size 1 . V.fromList <$> replicateM (size * 3) get where size = 2 ^ (fromIntegral bitDepth :: Int) putPalette :: Int -> Palette -> Put putPalette size pal = do V.mapM_ putWord8 (imageData pal) replicateM_ missingColorComponent (putWord8 0) where elemCount = 2 ^ size missingColorComponent = (elemCount - imageWidth pal) * 3 -------------------------------------------------- ---- GifImage -------------------------------------------------- data GifHeader = GifHeader { gifVersion :: GifVersion , gifScreenDescriptor :: LogicalScreenDescriptor , gifGlobalMap :: !Palette } instance Binary GifHeader where put v = do put $ gifVersion v let descr = gifScreenDescriptor v put descr putPalette (fromIntegral $ colorTableSize descr) $ gifGlobalMap v get = do version <- get screenDesc <- get palette <- if hasGlobalMap screenDesc then getPalette $ colorTableSize screenDesc else return greyPalette return GifHeader { gifVersion = version , gifScreenDescriptor = screenDesc , gifGlobalMap = palette } data GifFile = GifFile { gifHeader :: !GifHeader , gifImages :: [(Maybe GraphicControlExtension, GifImage)] , gifLoopingBehaviour :: GifLooping } putLooping :: GifLooping -> Put putLooping LoopingNever = return () putLooping LoopingForever = putLooping $ LoopingRepeat 0 putLooping (LoopingRepeat count) = do putWord8 extensionIntroducer putWord8 applicationLabel putWord8 11 -- the size putByteString $ BC.pack "NETSCAPE2.0" putWord8 3 -- size of sub block putWord8 1 putWord16le count putWord8 0 associateDescr :: [Block] -> [(Maybe GraphicControlExtension, GifImage)] associateDescr [] = [] associateDescr [BlockGraphicControl _] = [] associateDescr (BlockGraphicControl _ : rest@(BlockGraphicControl _ : _)) = associateDescr rest associateDescr (BlockImage img:xs) = (Nothing, img) : associateDescr xs associateDescr (BlockGraphicControl ctrl : BlockImage img : xs) = (Just ctrl, img) : associateDescr xs instance Binary GifFile where put v = do put $ gifHeader v let putter (Nothing, i) = put i putter (Just a, i) = put a >> put i putLooping $ gifLoopingBehaviour v mapM_ putter $ gifImages v put gifTrailer get = do hdr <- get blocks <- parseGifBlocks return GifFile { gifHeader = hdr , gifImages = associateDescr blocks , gifLoopingBehaviour = LoopingNever } substituteColors :: Palette -> Image Pixel8 -> Image PixelRGB8 substituteColors palette = pixelMap swaper where swaper n = pixelAt palette (fromIntegral n) 0 substituteColorsWithTransparency :: Int -> Image PixelRGBA8 -> Image Pixel8 -> Image PixelRGBA8 substituteColorsWithTransparency transparent palette = pixelMap swaper where swaper n | ix == transparent = PixelRGBA8 0 0 0 0 | otherwise = promotePixel $ pixelAt palette ix 0 where ix = fromIntegral n decodeImage :: GifImage -> Image Pixel8 decodeImage img = runST $ runBoolReader $ do outputVector <- lift . M.new $ width * height decodeLzw (imgData img) 12 lzwRoot outputVector frozenData <- lift $ V.unsafeFreeze outputVector return . deinterlaceGif $ Image { imageWidth = width , imageHeight = height , imageData = frozenData } where lzwRoot = fromIntegral $ imgLzwRootSize img width = fromIntegral $ gDescImageWidth descriptor height = fromIntegral $ gDescImageHeight descriptor isInterlaced = gDescIsInterlaced descriptor descriptor = imgDescriptor img deinterlaceGif | not isInterlaced = id | otherwise = deinterlaceGifImage deinterlaceGifImage :: Image Pixel8 -> Image Pixel8 deinterlaceGifImage img@(Image { imageWidth = w, imageHeight = h }) = generateImage generator w h where lineIndices = gifInterlacingIndices h generator x y = pixelAt img x y' where y' = lineIndices V.! y gifInterlacingIndices :: Int -> V.Vector Int gifInterlacingIndices height = V.accum (\_ v -> v) (V.replicate height 0) indices where indices = flip zip [0..] $ concat [ [0, 8 .. height - 1] , [4, 4 + 8 .. height - 1] , [2, 2 + 4 .. height - 1] , [1, 1 + 2 .. height - 1] ] paletteOf :: (ColorConvertible PixelRGB8 px) => Image px -> GifImage -> Image px paletteOf global GifImage { imgLocalPalette = Nothing } = global paletteOf _ GifImage { imgLocalPalette = Just p } = promoteImage p getFrameDelays :: GifFile -> [GifDelay] getFrameDelays GifFile { gifImages = [] } = [] getFrameDelays GifFile { gifImages = imgs } = map extractDelay imgs where extractDelay (ext, _) = case ext of Nothing -> 0 Just e -> fromIntegral $ gceDelay e transparentColorOf :: Maybe GraphicControlExtension -> Int transparentColorOf Nothing = 300 transparentColorOf (Just ext) | gceTransparentFlag ext = fromIntegral $ gceTransparentColorIndex ext | otherwise = 300 hasTransparency :: Maybe GraphicControlExtension -> Bool hasTransparency Nothing = False hasTransparency (Just control) = gceTransparentFlag control decodeAllGifImages :: GifFile -> [PalettedImage] decodeAllGifImages GifFile { gifImages = [] } = [] decodeAllGifImages GifFile { gifHeader = GifHeader { gifGlobalMap = palette , gifScreenDescriptor = wholeDescriptor } , gifImages = (firstControl, firstImage) : rest } | not (hasTransparency firstControl) = let backImage = generateImage (\_ _ -> backgroundColor) globalWidth globalHeight thisPalette = paletteOf palette firstImage baseImage = decodeImage firstImage initState = (thisPalette, firstControl, substituteColors thisPalette baseImage) scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage palette' = Palette' { _paletteSize = imageWidth thisPalette , _paletteData = imageData thisPalette } in PalettedRGB8 baseImage palette' : [TrueColorImage $ ImageRGB8 img | (_, _, img) <- tail $ scanl scanner initState rest] | otherwise = let backImage :: Image PixelRGBA8 backImage = generateImage (\_ _ -> transparentBackground) globalWidth globalHeight thisPalette :: Image PixelRGBA8 thisPalette = paletteOf (promoteImage palette) firstImage transparentCode = transparentColorOf firstControl decoded = substituteColorsWithTransparency transparentCode thisPalette $ decodeImage firstImage initState = (thisPalette, firstControl, decoded) scanner = gifAnimationApplyer (globalWidth, globalHeight) thisPalette backImage in [TrueColorImage $ ImageRGBA8 img | (_, _, img) <- scanl scanner initState rest] where globalWidth = fromIntegral $ screenWidth wholeDescriptor globalHeight = fromIntegral $ screenHeight wholeDescriptor transparentBackground = PixelRGBA8 r g b 0 where PixelRGB8 r g b = backgroundColor backgroundColor | hasGlobalMap wholeDescriptor = pixelAt palette (fromIntegral $ backgroundIndex wholeDescriptor) 0 | otherwise = PixelRGB8 0 0 0 gifAnimationApplyer :: forall px. (ColorConvertible PixelRGB8 px) => (Int, Int) -> Image px -> Image px -> (Image px, Maybe GraphicControlExtension, Image px) -> (Maybe GraphicControlExtension, GifImage) -> (Image px, Maybe GraphicControlExtension, Image px) gifAnimationApplyer (globalWidth, globalHeight) globalPalette backgroundImage (_, prevControl, img1) (controlExt, img2@(GifImage { imgDescriptor = descriptor })) = (thisPalette, controlExt, thisImage) where thisPalette :: Image px thisPalette = paletteOf globalPalette img2 thisImage = generateImage pixeler globalWidth globalHeight localWidth = fromIntegral $ gDescImageWidth descriptor localHeight = fromIntegral $ gDescImageHeight descriptor left = fromIntegral $ gDescPixelsFromLeft descriptor top = fromIntegral $ gDescPixelsFromTop descriptor isPixelInLocalImage x y = x >= left && x < left + localWidth && y >= top && y < top + localHeight decoded :: Image Pixel8 decoded = decodeImage img2 transparent :: Int transparent = case controlExt of Nothing -> 300 Just ext -> if gceTransparentFlag ext then fromIntegral $ gceTransparentColorIndex ext else 300 oldImage = case gceDisposalMethod <$> prevControl of Nothing -> img1 Just DisposalAny -> img1 Just DisposalDoNot -> img1 Just DisposalRestoreBackground -> backgroundImage Just DisposalRestorePrevious -> img1 Just (DisposalUnknown _) -> img1 pixeler x y | isPixelInLocalImage x y && code /= transparent = val where code = fromIntegral $ pixelAt decoded (x - left) (y - top) val = pixelAt thisPalette (fromIntegral code) 0 pixeler x y = pixelAt oldImage x y decodeFirstGifImage :: GifFile -> Either String (PalettedImage, Metadatas) decodeFirstGifImage img@GifFile { gifImages = (firstImage:_) } = case decodeAllGifImages img { gifImages = [firstImage] } of [] -> Left "No image after decoding" (i:_) -> Right (i, basicMetadata SourceGif (screenWidth hdr) (screenHeight hdr)) where hdr = gifScreenDescriptor $ gifHeader img decodeFirstGifImage _ = Left "No image in gif file" -- | Transform a raw gif image to an image, without modifying the pixels. This -- function can output the following images: -- -- * 'ImageRGB8' -- -- * 'ImageRGBA8' -- decodeGif :: B.ByteString -> Either String DynamicImage decodeGif img = decode img >>= (fmap (palettedToTrueColor . fst) . decodeFirstGifImage) -- | Transform a raw gif image to an image, without modifying the pixels. This -- function can output the following images: -- -- * 'ImageRGB8' -- -- * 'ImageRGBA8' -- -- Metadatas include Width & Height information. -- decodeGifWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeGifWithMetadata img = first palettedToTrueColor <$> decodeGifWithPaletteAndMetadata img -- | Return the gif image with metadata and palette. -- The palette is only returned for the first image of an -- animation and has no transparency. decodeGifWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeGifWithPaletteAndMetadata img = decode img >>= decodeFirstGifImage -- | Transform a raw gif to a list of images, representing -- all the images of an animation. decodeGifImages :: B.ByteString -> Either String [DynamicImage] decodeGifImages img = fmap palettedToTrueColor . decodeAllGifImages <$> decode img -- | Extract a list of frame delays from a raw gif. getDelaysGifImages :: B.ByteString -> Either String [GifDelay] getDelaysGifImages img = getFrameDelays <$> decode img -- | Default palette to produce greyscale images. greyPalette :: Palette greyPalette = generateImage toGrey 256 1 where toGrey x _ = PixelRGB8 ix ix ix where ix = fromIntegral x checkGifImageSizes :: [(a, b, Image px)] -> Bool checkGifImageSizes [] = False checkGifImageSizes ((_, _, img) : rest) = all checkDimension rest where width = imageWidth img height = imageHeight img checkDimension (_,_,Image { imageWidth = w, imageHeight = h }) = w == width && h == height checkPaletteValidity :: [(Palette, a, b)] -> Bool checkPaletteValidity [] = False checkPaletteValidity lst = and [h == 1 && w > 0 && w <= 256 | (p, _, _) <- lst , let w = imageWidth p h = imageHeight p ] areIndexAbsentFromPalette :: (Palette, a, Image Pixel8) -> Bool areIndexAbsentFromPalette (palette, _, img) = V.any isTooBig $ imageData img where paletteElemCount = imageWidth palette isTooBig v = fromIntegral v >= paletteElemCount computeMinimumLzwKeySize :: Palette -> Int computeMinimumLzwKeySize Image { imageWidth = itemCount } = go 2 where go k | 2 ^ k >= itemCount = k | otherwise = go $ k + 1 -- | Encode a gif animation to a bytestring. -- -- * Every image must have the same size -- -- * Every palette must have between one and 256 colors. -- encodeGifImages :: GifLooping -> [(Palette, GifDelay, Image Pixel8)] -> Either String L.ByteString encodeGifImages _ [] = Left "No image in list" encodeGifImages _ imageList | not $ checkGifImageSizes imageList = Left "Gif images have different size" | not $ checkPaletteValidity imageList = Left $ "Invalid palette size " ++ concat [show (imageWidth pal) ++ " "| (pal, _, _) <- imageList ] | any areIndexAbsentFromPalette imageList = Left "Image contains indexes absent from the palette" encodeGifImages looping imageList@((firstPalette, _,firstImage):_) = Right $ encode allFile where version = case imageList of [] -> GIF87a [_] -> GIF87a _:_:_ -> GIF89a allFile = GifFile { gifHeader = GifHeader { gifVersion = version , gifScreenDescriptor = logicalScreen , gifGlobalMap = firstPalette } , gifImages = toSerialize , gifLoopingBehaviour = looping } logicalScreen = LogicalScreenDescriptor { screenWidth = fromIntegral $ imageWidth firstImage , screenHeight = fromIntegral $ imageHeight firstImage , backgroundIndex = 0 , hasGlobalMap = True , colorResolution = 8 , isColorTableSorted = False , colorTableSize = 8 } paletteEqual p = imageData firstPalette == imageData p controlExtension 0 = Nothing controlExtension delay = Just GraphicControlExtension { gceDisposalMethod = DisposalAny , gceUserInputFlag = False , gceTransparentFlag = False , gceDelay = fromIntegral delay , gceTransparentColorIndex = 0 } toSerialize = [(controlExtension delay, GifImage { imgDescriptor = imageDescriptor lzwKeySize (paletteEqual palette) img , imgLocalPalette = Just palette , imgLzwRootSize = fromIntegral lzwKeySize , imgData = B.concat . L.toChunks . lzwEncode lzwKeySize $ imageData img }) | (palette, delay, img) <- imageList , let lzwKeySize = computeMinimumLzwKeySize palette ] imageDescriptor paletteSize palEqual img = ImageDescriptor { gDescPixelsFromLeft = 0 , gDescPixelsFromTop = 0 , gDescImageWidth = fromIntegral $ imageWidth img , gDescImageHeight = fromIntegral $ imageHeight img , gDescHasLocalMap = paletteSize > 0 && not palEqual , gDescIsInterlaced = False , gDescIsImgDescriptorSorted = False , gDescLocalColorTableSize = if palEqual then 0 else fromIntegral paletteSize } -- | Encode a greyscale image to a bytestring. encodeGifImage :: Image Pixel8 -> L.ByteString encodeGifImage img = case encodeGifImages LoopingNever [(greyPalette, 0, img)] of Left err -> error $ "Impossible:" ++ err Right v -> v -- | Encode an image with a given palette. -- Can return errors if the palette is ill-formed. -- -- * A palette must have between 1 and 256 colors -- encodeGifImageWithPalette :: Image Pixel8 -> Palette -> Either String L.ByteString encodeGifImageWithPalette img palette = encodeGifImages LoopingNever [(palette, 0, img)] -- | Write a greyscale in a gif file on the disk. writeGifImage :: FilePath -> Image Pixel8 -> IO () writeGifImage file = L.writeFile file . encodeGifImage -- | Write a list of images as a gif animation in a file. -- -- * Every image must have the same size -- -- * Every palette must have between one and 256 colors. -- writeGifImages :: FilePath -> GifLooping -> [(Palette, GifDelay, Image Pixel8)] -> Either String (IO ()) writeGifImages file looping lst = L.writeFile file <$> encodeGifImages looping lst -- | Write a gif image with a palette to a file. -- -- * A palette must have between 1 and 256 colors -- writeGifImageWithPalette :: FilePath -> Image Pixel8 -> Palette -> Either String (IO ()) writeGifImageWithPalette file img palette = L.writeFile file <$> encodeGifImageWithPalette img palette JuicyPixels-3.2.8/src/Codec/Picture/Png.hs0000644000000000000000000006211412763046173016476 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) -- files. -- -- 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( .. ) , decodePng , decodePngWithMetadata , decodePngWithPaletteAndMetadata , writePng , encodeDynamicPng , encodePalettedPng , encodePalettedPngWithMetadata , writeDynamicPng ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) #endif import Control.Arrow( first ) import Control.Monad( forM_, foldM_, when, void ) import Control.Monad.ST( ST, runST ) import Data.Monoid( (<>) ) import Data.Binary( Binary( get) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.List( find, zip4 ) import Data.Word( Word8, Word16, Word32 ) import qualified Codec.Compression.Zlib as Z import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU import qualified Data.ByteString.Lazy as Lb import Foreign.Storable ( Storable ) import Codec.Picture.Types import Codec.Picture.Metadata import Codec.Picture.Png.Type import Codec.Picture.Png.Export import Codec.Picture.Png.Metadata import Codec.Picture.InternalHelper -- | Simple structure used to hold information about Adam7 deinterlacing. -- A structure is used to avoid pollution of the module namespace. data Adam7MatrixInfo = Adam7MatrixInfo { adam7StartingRow :: [Int] , adam7StartingCol :: [Int] , adam7RowIncrement :: [Int] , adam7ColIncrement :: [Int] , adam7BlockHeight :: [Int] , adam7BlockWidth :: [Int] } -- | The real info about the matrix. adam7MatrixInfo :: Adam7MatrixInfo adam7MatrixInfo = Adam7MatrixInfo { adam7StartingRow = [0, 0, 4, 0, 2, 0, 1] , adam7StartingCol = [0, 4, 0, 2, 0, 1, 0] , adam7RowIncrement = [8, 8, 8, 4, 4, 2, 2] , adam7ColIncrement = [8, 8, 4, 4, 2, 2, 1] , adam7BlockHeight = [8, 8, 4, 4, 2, 2, 1] , adam7BlockWidth = [8, 4, 4, 2, 2, 1, 1] } unparsePngFilter :: Word8 -> Either String PngFilter {-# INLINE unparsePngFilter #-} unparsePngFilter 0 = Right FilterNone unparsePngFilter 1 = Right FilterSub unparsePngFilter 2 = Right FilterUp unparsePngFilter 3 = Right FilterAverage unparsePngFilter 4 = Right FilterPaeth unparsePngFilter _ = Left "Invalid scanline filter" getBounds :: (Monad m, Storable a) => M.STVector s a -> m (Int, Int) {-# INLINE getBounds #-} getBounds v = return (0, M.length v - 1) -- | Apply a filtering method on a reduced image. Apply the filter -- on each line, using the previous line (the one above it) to perform -- some prediction on the value. pngFiltering :: LineUnpacker s -> Int -> (Int, Int) -- ^ Image size -> B.ByteString -> Int -> ST s Int pngFiltering _ _ (imgWidth, imgHeight) _str initialIdx | imgWidth <= 0 || imgHeight <= 0 = return initialIdx pngFiltering unpacker beginZeroes (imgWidth, imgHeight) str initialIdx = do thisLine <- M.replicate (beginZeroes + imgWidth) 0 otherLine <- M.replicate (beginZeroes + imgWidth) 0 let folder _ _ lineIndex !idx | lineIndex >= imgHeight = return idx folder previousLine currentLine lineIndex !idx = do let byte = str `BU.unsafeIndex` idx let lineFilter = case unparsePngFilter byte of Right FilterNone -> filterNone Right FilterSub -> filterSub Right FilterAverage -> filterAverage Right FilterUp -> filterUp Right FilterPaeth -> filterPaeth _ -> filterNone idx' <- lineFilter previousLine currentLine $ idx + 1 unpacker lineIndex (stride, currentLine) folder currentLine previousLine (lineIndex + 1) idx' folder thisLine otherLine (0 :: Int) initialIdx where stride = fromIntegral beginZeroes lastIdx = beginZeroes + imgWidth - 1 -- The filter implementation are... well non-idiomatic -- to say the least, but my benchmarks proved me one thing, -- they are faster than mapM_, gained something like 5% with -- a rewrite from mapM_ to this direct version filterNone, filterSub, filterUp, filterPaeth, filterAverage :: PngLine s -> PngLine s -> Int -> ST s Int filterNone !_previousLine !thisLine = inner beginZeroes where inner idx !readIdx | idx > lastIdx = return readIdx | otherwise = do let byte = str `BU.unsafeIndex` readIdx (thisLine `M.unsafeWrite` idx) byte inner (idx + 1) $ readIdx + 1 filterSub !_previousLine !thisLine = inner beginZeroes where inner idx !readIdx | idx > lastIdx = return readIdx | otherwise = do let byte = str `BU.unsafeIndex` readIdx val <- thisLine `M.unsafeRead` (idx - stride) (thisLine `M.unsafeWrite` idx) $ byte + val inner (idx + 1) $ readIdx + 1 filterUp !previousLine !thisLine = inner beginZeroes where inner idx !readIdx | idx > lastIdx = return readIdx | otherwise = do let byte = str `BU.unsafeIndex` readIdx val <- previousLine `M.unsafeRead` idx (thisLine `M.unsafeWrite` idx) $ val + byte inner (idx + 1) $ readIdx + 1 filterAverage !previousLine !thisLine = inner beginZeroes where inner idx !readIdx | idx > lastIdx = return readIdx | otherwise = do let byte = str `BU.unsafeIndex` readIdx valA <- thisLine `M.unsafeRead` (idx - stride) valB <- previousLine `M.unsafeRead` idx let a' = fromIntegral valA b' = fromIntegral valB average = fromIntegral ((a' + b') `div` (2 :: Word16)) writeVal = byte + average (thisLine `M.unsafeWrite` idx) writeVal inner (idx + 1) $ readIdx + 1 filterPaeth !previousLine !thisLine = inner beginZeroes where inner idx !readIdx | idx > lastIdx = return readIdx | otherwise = do let byte = str `BU.unsafeIndex` readIdx valA <- thisLine `M.unsafeRead` (idx - stride) valC <- previousLine `M.unsafeRead` (idx - stride) valB <- previousLine `M.unsafeRead` idx (thisLine `M.unsafeWrite` idx) $ byte + paeth valA valB valC inner (idx + 1) $ readIdx + 1 paeth a b c | pa <= pb && pa <= pc = a | pb <= pc = b | otherwise = c where a' = fromIntegral a :: Int b' = fromIntegral b c' = fromIntegral c p = a' + b' - c' pa = abs $ p - a' pb = abs $ p - b' pc = abs $ p - c' -- | Directly stolen from the definition in the standard (on W3C page), -- pixel predictor. type PngLine s = M.STVector s Word8 type LineUnpacker s = Int -> (Int, PngLine s) -> ST s () type StrideInfo = (Int, Int) type BeginOffset = (Int, Int) -- | Unpack lines where bit depth is 8 byteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s byteUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do (_, maxIdx) <- getBounds line let realTop = beginTop + h * strideHeight lineIndex = realTop * imgWidth pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` sampleCount inner pixelIndex | pixelIndex > pixelToRead = return () | otherwise = do let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft destSampleIndex = destPixelIndex * sampleCount srcPixelIndex = pixelIndex * sampleCount + beginIdx perPixel sample | sample >= sampleCount = return () | otherwise = do val <- line `M.unsafeRead` (srcPixelIndex + sample) let writeIdx = destSampleIndex + sample (arr `M.unsafeWrite` writeIdx) val perPixel (sample + 1) perPixel 0 inner (pixelIndex + 1) inner 0 -- | Unpack lines where bit depth is 1 bitUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s bitUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do (_, endLine) <- getBounds line let realTop = beginTop + h * strideHeight lineIndex = realTop * imgWidth (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth subPadd | subImageRest > 0 = 1 | otherwise = 0 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 8 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do val <- line `M.unsafeRead` (pixelIndex + beginIdx) let writeIdx n = lineIndex + (pixelIndex * 8 + n) * strideWidth + beginLeft forM_ [0 .. 7] $ \bit -> (arr `M.unsafeWrite` writeIdx (7 - bit)) ((val `unsafeShiftR` bit) .&. 1) when (lineRest /= 0) (do val <- line `M.unsafeRead` endLine let writeIdx n = lineIndex + (pixelToRead * 8 + n) * strideWidth + beginLeft forM_ [0 .. lineRest - 1] $ \bit -> (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (7 - bit)) .&. 0x1)) -- | Unpack lines when bit depth is 2 twoBitsUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s twoBitsUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do (_, endLine) <- getBounds line let realTop = beginTop + h * strideHeight lineIndex = realTop * imgWidth (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth subPadd | subImageRest > 0 = 1 | otherwise = 0 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 4 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do val <- line `M.unsafeRead` (pixelIndex + beginIdx) let writeIdx n = lineIndex + (pixelIndex * 4 + n) * strideWidth + beginLeft (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 6) .&. 0x3 (arr `M.unsafeWrite` writeIdx 1) $ (val `unsafeShiftR` 4) .&. 0x3 (arr `M.unsafeWrite` writeIdx 2) $ (val `unsafeShiftR` 2) .&. 0x3 (arr `M.unsafeWrite` writeIdx 3) $ val .&. 0x3 when (lineRest /= 0) (do val <- line `M.unsafeRead` endLine let writeIdx n = lineIndex + (pixelToRead * 4 + n) * strideWidth + beginLeft forM_ [0 .. lineRest - 1] $ \bit -> (arr `M.unsafeWrite` writeIdx bit) ((val `unsafeShiftR` (6 - 2 * bit)) .&. 0x3)) halfByteUnpacker :: Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s halfByteUnpacker _ (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do (_, endLine) <- getBounds line let realTop = beginTop + h * strideHeight lineIndex = realTop * imgWidth (lineWidth, subImageRest) = (imgWidth - beginLeft) `divMod` strideWidth subPadd | subImageRest > 0 = 1 | otherwise = 0 (pixelToRead, lineRest) = (lineWidth + subPadd) `divMod` 2 forM_ [0 .. pixelToRead - 1] $ \pixelIndex -> do val <- line `M.unsafeRead` (pixelIndex + beginIdx) let writeIdx n = lineIndex + (pixelIndex * 2 + n) * strideWidth + beginLeft (arr `M.unsafeWrite` writeIdx 0) $ (val `unsafeShiftR` 4) .&. 0xF (arr `M.unsafeWrite` writeIdx 1) $ val .&. 0xF when (lineRest /= 0) (do val <- line `M.unsafeRead` endLine let writeIdx = lineIndex + (pixelToRead * 2) * strideWidth + beginLeft (arr `M.unsafeWrite` writeIdx) $ (val `unsafeShiftR` 4) .&. 0xF) shortUnpacker :: Int -> MutableImage s Word16 -> StrideInfo -> BeginOffset -> LineUnpacker s shortUnpacker sampleCount (MutableImage{ mutableImageWidth = imgWidth, mutableImageData = arr }) (strideWidth, strideHeight) (beginLeft, beginTop) h (beginIdx, line) = do (_, maxIdx) <- getBounds line let realTop = beginTop + h * strideHeight lineIndex = realTop * imgWidth pixelToRead = min (imgWidth - 1) $ (maxIdx - beginIdx) `div` (sampleCount * 2) forM_ [0 .. pixelToRead] $ \pixelIndex -> do let destPixelIndex = lineIndex + pixelIndex * strideWidth + beginLeft destSampleIndex = destPixelIndex * sampleCount srcPixelIndex = pixelIndex * sampleCount * 2 + beginIdx forM_ [0 .. sampleCount - 1] $ \sample -> do highBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 0) lowBits <- line `M.unsafeRead` (srcPixelIndex + sample * 2 + 1) let fullValue = fromIntegral lowBits .|. (fromIntegral highBits `unsafeShiftL` 8) writeIdx = destSampleIndex + sample (arr `M.unsafeWrite` writeIdx) fullValue -- | Transform a scanline to a bunch of bytes. Bytes are then packed -- into pixels at a further step. scanlineUnpacker8 :: Int -> Int -> MutableImage s Word8 -> StrideInfo -> BeginOffset -> LineUnpacker s scanlineUnpacker8 1 = bitUnpacker scanlineUnpacker8 2 = twoBitsUnpacker scanlineUnpacker8 4 = halfByteUnpacker scanlineUnpacker8 8 = byteUnpacker scanlineUnpacker8 _ = error "Impossible bit depth" byteSizeOfBitLength :: Int -> Int -> Int -> Int byteSizeOfBitLength pixelBitDepth sampleCount dimension = size + (if rest /= 0 then 1 else 0) where (size, rest) = (pixelBitDepth * dimension * sampleCount) `quotRem` 8 scanLineInterleaving :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) -> B.ByteString -> ST s () scanLineInterleaving depth sampleCount (imgWidth, imgHeight) unpacker str = 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) -- | Given data and image size, recreate an image with deinterlaced -- data for PNG's adam 7 method. adam7Unpack :: Int -> Int -> (Int, Int) -> (StrideInfo -> BeginOffset -> LineUnpacker s) -> B.ByteString -> ST s () adam7Unpack depth sampleCount (imgWidth, imgHeight) unpacker str = void $ foldM_ (\i f -> f i) 0 subImages where Adam7MatrixInfo { adam7StartingRow = startRows , adam7RowIncrement = rowIncrement , adam7StartingCol = startCols , adam7ColIncrement = colIncrement } = adam7MatrixInfo subImages = [pngFiltering (unpacker (incrW, incrH) (beginW, beginH)) strideInfo (byteWidth, passHeight) str | (beginW, incrW, beginH, incrH) <- zip4 startCols colIncrement startRows rowIncrement , let passWidth = sizer imgWidth beginW incrW passHeight = sizer imgHeight beginH incrH byteWidth = byteSizeOfBitLength depth sampleCount passWidth ] strideInfo | depth < 8 = 1 | otherwise = sampleCount * (depth `div` 8) sizer dimension begin increment | dimension <= begin = 0 | otherwise = outDim + (if restDim /= 0 then 1 else 0) where (outDim, restDim) = (dimension - begin) `quotRem` increment -- | deinterlace picture in function of the method indicated -- in the iHDR deinterlacer :: PngIHdr -> B.ByteString -> ST s (Either (V.Vector Word8) (V.Vector Word16)) deinterlacer (PngIHdr { width = w, height = h, colourType = imgKind , interlaceMethod = method, bitDepth = depth }) str = do let compCount = sampleCountOfImageType imgKind arraySize = fromIntegral $ w * h * compCount deinterlaceFunction = case method of PngNoInterlace -> scanLineInterleaving PngInterlaceAdam7 -> adam7Unpack iBitDepth = fromIntegral depth if iBitDepth <= 8 then do imgArray <- M.new arraySize let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray deinterlaceFunction iBitDepth (fromIntegral compCount) (fromIntegral w, fromIntegral h) (scanlineUnpacker8 iBitDepth (fromIntegral compCount) mutableImage) str Left <$> V.unsafeFreeze imgArray else do imgArray <- M.new arraySize let mutableImage = MutableImage (fromIntegral w) (fromIntegral h) imgArray deinterlaceFunction iBitDepth (fromIntegral compCount) (fromIntegral w, fromIntegral h) (shortUnpacker (fromIntegral compCount) mutableImage) str Right <$> V.unsafeFreeze imgArray generateGreyscalePalette :: Word8 -> PngPalette generateGreyscalePalette bits = Palette' (maxValue+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 sampleCountOfImageType PngTrueColour = 3 sampleCountOfImageType PngIndexedColor = 1 sampleCountOfImageType PngGreyscaleWithAlpha = 2 sampleCountOfImageType PngTrueColourWithAlpha = 4 paletteRGB1, paletteRGB2, paletteRGB4 :: PngPalette paletteRGB1 = generateGreyscalePalette 1 paletteRGB2 = generateGreyscalePalette 2 paletteRGB4 = generateGreyscalePalette 4 addTransparencyToPalette :: PngPalette -> Lb.ByteString -> Palette' PixelRGBA8 addTransparencyToPalette pal transpBuffer = Palette' (_paletteSize pal) . imageData . pixelMapXY addOpacity $ palettedAsImage pal where maxi = fromIntegral $ Lb.length transpBuffer addOpacity ix _ (PixelRGB8 r g b) | ix < maxi = PixelRGBA8 r g b $ Lb.index transpBuffer (fromIntegral ix) addOpacity _ _ (PixelRGB8 r g b) = PixelRGBA8 r g b 255 unparse :: PngIHdr -> Maybe PngPalette -> [Lb.ByteString] -> PngImageType -> B.ByteString -> Either String PalettedImage unparse ihdr _ t PngGreyscale bytes | bitDepth ihdr == 1 = unparse ihdr (Just paletteRGB1) t PngIndexedColor bytes | bitDepth ihdr == 2 = unparse ihdr (Just paletteRGB2) t PngIndexedColor bytes | bitDepth ihdr == 4 = unparse ihdr (Just paletteRGB4) t PngIndexedColor bytes | otherwise = fmap TrueColorImage . toImage ihdr ImageY8 ImageY16 $ runST $ deinterlacer ihdr bytes unparse _ Nothing _ PngIndexedColor _ = Left "no valid palette found" unparse ihdr _ _ PngTrueColour bytes = fmap TrueColorImage . toImage ihdr ImageRGB8 ImageRGB16 $ runST $ deinterlacer ihdr bytes unparse ihdr _ _ PngGreyscaleWithAlpha bytes = fmap TrueColorImage . toImage ihdr ImageYA8 ImageYA16 $ runST $ deinterlacer ihdr bytes unparse ihdr _ _ PngTrueColourWithAlpha bytes = fmap TrueColorImage . toImage ihdr ImageRGBA8 ImageRGBA16 $ runST $ deinterlacer ihdr bytes unparse ihdr (Just plte) transparency PngIndexedColor bytes = palette8 ihdr plte transparency $ runST $ deinterlacer ihdr bytes toImage :: forall a pxWord8 pxWord16 . PngIHdr -> (Image pxWord8 -> DynamicImage) -> (Image pxWord16 -> DynamicImage) -> Either (V.Vector (PixelBaseComponent pxWord8)) (V.Vector (PixelBaseComponent pxWord16)) -> Either a DynamicImage toImage hdr const1 const2 lr = Right $ case lr of Left a -> const1 $ Image w h a Right a -> const2 $ Image w h a where w = fromIntegral $ width hdr h = fromIntegral $ height hdr palette8 :: PngIHdr -> PngPalette -> [Lb.ByteString] -> Either (V.Vector Word8) t -> Either String PalettedImage palette8 hdr palette transparency eimg = case (transparency, eimg) of ([c], Left img) -> Right . PalettedRGBA8 (Image w h img) $ addTransparencyToPalette palette c (_, Left img) -> return $ PalettedRGB8 (Image w h img) palette (_, Right _) -> Left "Invalid bit depth for paleted image" where w = fromIntegral $ width hdr h = fromIntegral $ height hdr -- | Transform a raw png image to an image, without modifying the -- underlying pixel type. If the image is greyscale and < 8 bits, -- a transformation to RGBA8 is performed. This should change -- in the future. -- The resulting image let you manage the pixel types. -- -- This function can output the following images: -- -- * 'ImageY8' -- -- * 'ImageY16' -- -- * 'ImageYA8' -- -- * 'ImageYA16' -- -- * 'ImageRGB8' -- -- * 'ImageRGB16' -- -- * 'ImageRGBA8' -- -- * 'ImageRGBA16' -- decodePng :: B.ByteString -> Either String DynamicImage decodePng = fmap fst . decodePngWithMetadata -- | Decode a PNG file with, possibly, separated palette. decodePngWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodePngWithMetadata b = first palettedToTrueColor <$> decodePngWithPaletteAndMetadata b -- | Same as 'decodePng' but also extract meta datas present -- in the files. decodePngWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodePngWithPaletteAndMetadata byte = do rawImg <- runGetStrict get byte let ihdr = header rawImg metadatas = basicMetadata SourcePng (width ihdr) (height ihdr) <> extractMetadatas rawImg compressedImageData = Lb.concat [chunkData chunk | chunk <- chunks rawImg , chunkType chunk == iDATSignature] zlibHeaderSize = 1 {- compression method/flags code -} + 1 {- Additional flags/check bits -} + 4 {-CRC-} transparencyColor = [ chunkData chunk | chunk <- chunks rawImg , chunkType chunk == tRNSSignature ] if Lb.length compressedImageData <= zlibHeaderSize then Left "Invalid data size" else let imgData = Z.decompress compressedImageData parseableData = B.concat $ Lb.toChunks imgData palette = do p <- find (\c -> pLTESignature == chunkType c) $ chunks rawImg case parsePalette p of Left _ -> Nothing Right plte -> return plte in (, metadatas) <$> unparse ihdr palette transparencyColor (colourType ihdr) parseableData {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/Jpg.hs0000644000000000000000000013140012763046173016465 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -fspec-constr-count=5 #-} -- | Module used for JPEG file loading and writing. module Codec.Picture.Jpg( decodeJpeg , decodeJpegWithMetadata , encodeJpegAtQuality , encodeJpegAtQualityWithMetadata , encodeDirectJpegAtQualityWithMetadata , encodeJpeg , JpgEncodable ) where #if !MIN_VERSION_base(4,8,0) import Data.Foldable( foldMap ) import Data.Monoid( mempty ) import Control.Applicative( pure, (<$>) ) #endif import Control.Applicative( (<|>) ) import Control.Arrow( (>>>) ) import Control.Monad( when, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Trans( lift ) import Control.Monad.Trans.RWS.Strict( RWS, modify, tell, gets, execRWS ) import Data.Bits( (.|.), unsafeShiftL ) import Data.Monoid( (<>) ) import Data.Int( Int16, Int32 ) import Data.Word(Word8, Word32) import Data.Binary( Binary(..), encode ) import Data.STRef( newSTRef, writeSTRef, readSTRef ) import Data.Vector( (//) ) import Data.Vector.Unboxed( (!) ) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types import Codec.Picture.Metadata( Metadatas , SourceFormat( SourceJpeg ) , basicMetadata ) import Codec.Picture.Tiff.Types import Codec.Picture.Tiff.Metadata import Codec.Picture.Jpg.Types import Codec.Picture.Jpg.Common import Codec.Picture.Jpg.Progressive import Codec.Picture.Jpg.DefaultTable import Codec.Picture.Jpg.FastDct import Codec.Picture.Jpg.Metadata quantize :: MacroBlock Int16 -> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32) quantize table block = update 0 where update 64 = return block update idx = do val <- block `M.unsafeRead` idx let q = fromIntegral (table `VS.unsafeIndex` idx) finalValue = (val + (q `div` 2)) `quot` q -- rounded integer division (block `M.unsafeWrite` idx) finalValue update $ idx + 1 powerOf :: Int32 -> Word32 powerOf 0 = 0 powerOf n = limit 1 0 where val = abs n limit range i | val < range = i limit range i = limit (2 * range) (i + 1) encodeInt :: BoolWriteStateRef s -> Word32 -> Int32 -> ST s () {-# INLINE encodeInt #-} encodeInt st ssss n | n > 0 = writeBits' st (fromIntegral n) (fromIntegral ssss) encodeInt st ssss n = writeBits' st (fromIntegral $ n - 1) (fromIntegral ssss) -- | Assume the macro block is initialized with zeroes acCoefficientsDecode :: HuffmanPackedTree -> MutableMacroBlock s Int16 -> BoolReader s (MutableMacroBlock s Int16) acCoefficientsDecode acTree mutableBlock = parseAcCoefficient 1 >> return mutableBlock where parseAcCoefficient n | n >= 64 = return () | otherwise = do rrrrssss <- decodeRrrrSsss acTree case rrrrssss of ( 0, 0) -> return () (0xF, 0) -> parseAcCoefficient (n + 16) (rrrr, ssss) -> do decoded <- fromIntegral <$> decodeInt ssss lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded parseAcCoefficient (n + rrrr + 1) -- | Decompress a macroblock from a bitstream given the current configuration -- from the frame. decompressMacroBlock :: HuffmanPackedTree -- ^ Tree used for DC coefficient -> HuffmanPackedTree -- ^ Tree used for Ac coefficient -> MacroBlock Int16 -- ^ Current quantization table -> MutableMacroBlock s Int16 -- ^ A zigzag table, to avoid allocation -> DcCoefficient -- ^ Previous dc value -> BoolReader s (DcCoefficient, MutableMacroBlock s Int16) decompressMacroBlock dcTree acTree quantizationTable zigzagBlock previousDc = do dcDeltaCoefficient <- dcCoefficientDecode dcTree block <- lift createEmptyMutableMacroBlock let neoDcCoefficient = previousDc + dcDeltaCoefficient lift $ (block `M.unsafeWrite` 0) neoDcCoefficient fullBlock <- acCoefficientsDecode acTree block decodedBlock <- lift $ decodeMacroBlock quantizationTable zigzagBlock fullBlock return (neoDcCoefficient, decodedBlock) pixelClamp :: Int16 -> Word8 pixelClamp n = fromIntegral . min 255 $ max 0 n unpack444Y :: Int -- ^ component index -> Int -- ^ x -> Int -- ^ y -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () unpack444Y _ x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) block = blockVert baseIdx 0 zero where zero = 0 :: Int baseIdx = x * dctBlockSize + y * dctBlockSize * imgWidth blockVert _ _ j | j >= dctBlockSize = return () blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero where blockHoriz _ readIdx i | i >= dctBlockSize = blockVert (writeIdx + imgWidth) readIdx $ j + 1 blockHoriz idx readIdx i = do val <- pixelClamp <$> (block `M.unsafeRead` readIdx) (img `M.unsafeWrite` idx) val blockHoriz (idx + 1) (readIdx + 1) $ i + 1 unpack444Ycbcr :: Int -- ^ Component index -> Int -- ^ x -> Int -- ^ y -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () unpack444Ycbcr compIdx x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) block = blockVert baseIdx 0 zero where zero = 0 :: Int baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx blockVert _ _ j | j >= dctBlockSize = return () blockVert idx readIdx j = do val0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) val1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) val2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) val3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) val4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) val5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) val6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) val7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) (img `M.unsafeWrite` idx) val0 (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 (img `M.unsafeWrite` (idx + (3 * 5))) val5 (img `M.unsafeWrite` (idx + (3 * 6))) val6 (img `M.unsafeWrite` (idx + (3 * 7))) val7 blockVert (idx + 3 * imgWidth) (readIdx + dctBlockSize) $ j + 1 {-where blockHoriz _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth * 3) readIdx $ j + 1-} {-blockHoriz idx readIdx i = do-} {-val <- pixelClamp <$> (block `M.unsafeRead` readIdx) -} {-(img `M.unsafeWrite` idx) val-} {-blockHoriz (idx + 3) (readIdx + 1) $ i + 1-} unpack421Ycbcr :: Int -- ^ Component index -> Int -- ^ x -> Int -- ^ y -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () unpack421Ycbcr compIdx x y (MutableImage { mutableImageWidth = imgWidth, mutableImageHeight = _, mutableImageData = img }) block = blockVert baseIdx 0 zero where zero = 0 :: Int baseIdx = (x * dctBlockSize + y * dctBlockSize * imgWidth) * 3 + compIdx lineOffset = imgWidth * 3 blockVert _ _ j | j >= dctBlockSize = return () blockVert idx readIdx j = do v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) v1 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 1)) v2 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 2)) v3 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 3)) v4 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 4)) v5 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 5)) v6 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 6)) v7 <- pixelClamp <$> (block `M.unsafeRead` (readIdx + 7)) (img `M.unsafeWrite` idx) v0 (img `M.unsafeWrite` (idx + 3)) v0 (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 (img `M.unsafeWrite` (idx + 6 * 3)) v3 (img `M.unsafeWrite` (idx + 6 * 3 + 3)) v3 (img `M.unsafeWrite` (idx + 6 * 4)) v4 (img `M.unsafeWrite` (idx + 6 * 4 + 3)) v4 (img `M.unsafeWrite` (idx + 6 * 5)) v5 (img `M.unsafeWrite` (idx + 6 * 5 + 3)) v5 (img `M.unsafeWrite` (idx + 6 * 6)) v6 (img `M.unsafeWrite` (idx + 6 * 6 + 3)) v6 (img `M.unsafeWrite` (idx + 6 * 7)) v7 (img `M.unsafeWrite` (idx + 6 * 7 + 3)) v7 blockVert (idx + lineOffset) (readIdx + dctBlockSize) $ j + 1 type Unpacker s = Int -- ^ component index -> Int -- ^ x -> Int -- ^ y -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () type JpgScripter s a = 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 , app14Marker :: !(Maybe JpgAdobeApp14) , app0JFifMarker :: !(Maybe JpgJFIFApp0) , app1ExifMarker :: !(Maybe [ImageFileDirectory]) , componentIndexMapping :: ![(Word8, Int)] , isProgressive :: !Bool , maximumHorizontalResolution :: !Int , maximumVerticalResolution :: !Int , seenBlobs :: !Int } emptyDecoderState :: JpgDecoderState emptyDecoderState = JpgDecoderState { dcDecoderTables = let (_, dcLuma) = prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable (_, dcChroma) = prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable in V.fromList [ dcLuma, dcChroma, dcLuma, dcChroma ] , 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 , componentIndexMapping = [] , app14Marker = Nothing , app0JFifMarker = Nothing , app1ExifMarker = Nothing , isProgressive = False , maximumHorizontalResolution = 0 , maximumVerticalResolution = 0 , seenBlobs = 0 } -- | This pseudo interpreter interpret the Jpg frame for the huffman, -- quant table and restart interval parameters. jpgMachineStep :: JpgFrame -> JpgScripter s () jpgMachineStep (JpgAdobeAPP14 app14) = modify $ \s -> s { app14Marker = Just app14 } jpgMachineStep (JpgExif exif) = modify $ \s -> s { app1ExifMarker = Just exif } jpgMachineStep (JpgJFIF app0) = modify $ \s -> s { app0JFifMarker = Just app0 } jpgMachineStep (JpgAppFrame _ _) = pure () jpgMachineStep (JpgExtension _ _) = pure () 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 compMapping <- gets componentIndexMapping comp <- case lookup (componentSelector scanSpec) compMapping of Nothing -> fail "Jpg decoding error - bad component selector in blob." Just v -> return v let maximumHuffmanTable = 4 dcIndex = min (maximumHuffmanTable - 1) . fromIntegral $ dcEntropyCodingTable scanSpec acIndex = min (maximumHuffmanTable - 1) . fromIntegral $ acEntropyCodingTable scanSpec dcTree <- gets $ (V.! dcIndex) . dcDecoderTables acTree <- gets $ (V.! acIndex) . acDecoderTables isProgressiveImage <- gets isProgressive maxiW <- gets maximumHorizontalResolution maxiH <- gets maximumVerticalResolution restart <- gets currentRestartInterv frameInfo <- gets currentFrame blobId <- gets seenBlobs case frameInfo of Nothing -> fail "Jpg decoding error - no previous frame" Just v -> do let compDesc = jpgComponents v !! comp compCount = length $ jpgComponents v xSampling = fromIntegral $ horizontalSamplingFactor compDesc ySampling = fromIntegral $ verticalSamplingFactor compDesc componentSubSampling = (maxiW - xSampling + 1, maxiH - ySampling + 1) (xCount, yCount) | scanCount > 1 || isProgressiveImage = (xSampling, ySampling) | otherwise = (1, 1) pure [ (JpgUnpackerParameter { dcHuffmanTree = dcTree , acHuffmanTree = acTree , componentIndex = comp , restartInterval = fromIntegral restart , componentWidth = xSampling , componentHeight = ySampling , subSampling = componentSubSampling , successiveApprox = (approxLow, approxHigh) , readerIndex = blobId , indiceVector = if scanCount == 1 then 0 else 1 , coefficientRange = ( fromIntegral selectionLow , fromIntegral selectionHigh ) , blockIndex = y * xSampling + x , blockMcuX = x , blockMcuY = y }, unpackerDecision compCount componentSubSampling) | y <- [0 .. yCount - 1] , x <- [0 .. xCount - 1] ] jpgMachineStep (JpgScans kind hdr) = modify $ \s -> s { currentFrame = Just hdr , componentIndexMapping = [(componentIdentifier comp, ix) | (ix, comp) <- zip [0..] $ jpgComponents hdr] , isProgressive = case kind of JpgProgressiveDCTHuffman -> True _ -> False , maximumHorizontalResolution = fromIntegral $ maximum horizontalResolutions , maximumVerticalResolution = fromIntegral $ maximum verticalResolutions } where components = jpgComponents hdr horizontalResolutions = map horizontalSamplingFactor components verticalResolutions = map verticalSamplingFactor components jpgMachineStep (JpgIntervalRestart restart) = modify $ \s -> s { currentRestartInterv = fromIntegral restart } 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 } 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 jpgMachineStep (JpgQuantTable tables) = mapM_ placeQuantizationTables tables where placeQuantizationTables table = do let idx = fromIntegral $ quantDestination table tableData = quantTable table modify $ \s -> s { quantizationMatrices = quantizationMatrices s // [(idx, tableData)] } unpackerDecision :: Int -> (Int, Int) -> Unpacker s unpackerDecision 1 (1, 1) = unpack444Y unpackerDecision 3 (1, 1) = unpack444Ycbcr unpackerDecision _ (2, 1) = unpack421Ycbcr unpackerDecision compCount (xScalingFactor, yScalingFactor) = unpackMacroBlock compCount xScalingFactor yScalingFactor decodeImage :: JpgFrameHeader -> V.Vector (MacroBlock Int16) -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] -> MutableImage s PixelYCbCr8 -- ^ Result image to write into -> ST s (MutableImage s PixelYCbCr8) decodeImage frame quants lst outImage = do let compCount = length $ jpgComponents frame zigZagArray <- createEmptyMutableMacroBlock dcArray <- M.replicate compCount 0 :: ST s (M.STVector s DcCoefficient) resetCounter <- newSTRef restartIntervalValue forM_ lst $ \(params, str) -> do let componentsInfo = V.fromList params compReader = initBoolStateJpg . B.concat $ L.toChunks str maxiW = maximum [fst $ subSampling c | (c,_) <- params] maxiH = maximum [snd $ subSampling c | (c,_) <- params] imageBlockWidth = toBlockSize imgWidth imageBlockHeight = toBlockSize imgHeight imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH execBoolReader compReader $ rasterMap imageMcuWidth imageMcuHeight $ \x y -> do resetLeft <- lift $ readSTRef resetCounter if resetLeft == 0 then do lift $ M.set dcArray 0 byteAlignJpg _restartCode <- decodeRestartInterval lift $ resetCounter `writeSTRef` (restartIntervalValue - 1) else lift $ resetCounter `writeSTRef` (resetLeft - 1) V.forM_ componentsInfo $ \(comp, unpack) -> do let compIdx = componentIndex comp dcTree = dcHuffmanTree comp acTree = acHuffmanTree comp quantId = fromIntegral . quantizationTableDest $ jpgComponents frame !! compIdx qTable = quants V.! min 3 quantId xd = blockMcuX comp yd = blockMcuY comp (subX, subY) = subSampling comp dc <- lift $ dcArray `M.unsafeRead` compIdx (dcCoeff, block) <- decompressMacroBlock dcTree acTree qTable zigZagArray $ fromIntegral dc lift $ (dcArray `M.unsafeWrite` compIdx) dcCoeff let verticalLimited = y == imageMcuHeight - 1 if (x == imageMcuWidth - 1) || verticalLimited then lift $ unpackMacroBlock imgComponentCount subX subY compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block else lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block return outImage where imgComponentCount = length $ jpgComponents frame imgWidth = fromIntegral $ jpgWidth frame imgHeight = fromIntegral $ jpgHeight frame restartIntervalValue = case lst of ((p,_):_,_): _ -> restartInterval p _ -> -1 gatherImageKind :: [JpgFrame] -> Maybe JpgImageKind gatherImageKind lst = case [k | JpgScans k _ <- lst, isDctSpecifier k] of [JpgBaselineDCTHuffman] -> Just BaseLineDCT [JpgProgressiveDCTHuffman] -> Just ProgressiveDCT _ -> Nothing where isDctSpecifier JpgProgressiveDCTHuffman = True isDctSpecifier JpgBaselineDCTHuffman = True isDctSpecifier _ = False gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) gatherScanInfo img = head [(a, b) | JpgScans a b <- jpgFrame img] dynamicOfColorSpace :: (Monad m) => Maybe JpgColorSpace -> Int -> Int -> VS.Vector Word8 -> m DynamicImage dynamicOfColorSpace Nothing _ _ _ = fail "Unknown color space" dynamicOfColorSpace (Just color) w h imgData = case color of JpgColorSpaceCMYK -> return . ImageCMYK8 $ Image w h imgData JpgColorSpaceYCCK -> let ymg = Image w h $ VS.map (255-) imgData :: Image PixelYCbCrK8 in return . ImageCMYK8 $ convertImage ymg JpgColorSpaceYCbCr -> return . ImageYCbCr8 $ Image w h imgData JpgColorSpaceRGB -> return . ImageRGB8 $ Image w h imgData JpgColorSpaceYA -> return . ImageYA8 $ Image w h imgData JpgColorSpaceY -> return . ImageY8 $ Image w h imgData colorSpace -> fail $ "Wrong color space : " ++ show colorSpace colorSpaceOfAdobe :: Int -> JpgAdobeApp14 -> Maybe JpgColorSpace colorSpaceOfAdobe compCount app = case (compCount, _adobeTransform app) of (3, AdobeYCbCr) -> pure JpgColorSpaceYCbCr (1, AdobeUnknown) -> pure JpgColorSpaceY (3, AdobeUnknown) -> pure JpgColorSpaceRGB (4, AdobeYCck) -> pure JpgColorSpaceYCCK {-(4, AdobeUnknown) -> pure JpgColorSpaceCMYKInverted-} _ -> Nothing colorSpaceOfState :: JpgDecoderState -> Maybe JpgColorSpace colorSpaceOfState st = do hdr <- currentFrame st let compStr = [toEnum . fromEnum $ componentIdentifier comp | comp <- jpgComponents hdr] app14 = do marker <- app14Marker st colorSpaceOfAdobe (length compStr) marker app14 <|> colorSpaceOfComponentStr compStr colorSpaceOfComponentStr :: String -> Maybe JpgColorSpace colorSpaceOfComponentStr s = case s of [_] -> pure JpgColorSpaceY [_,_] -> pure JpgColorSpaceYA "\0\1\2" -> pure JpgColorSpaceYCbCr "\1\2\3" -> pure JpgColorSpaceYCbCr "RGB" -> pure JpgColorSpaceRGB "YCc" -> pure JpgColorSpaceYCC [_,_,_] -> pure JpgColorSpaceYCbCr "RGBA" -> pure JpgColorSpaceRGBA "YCcA" -> pure JpgColorSpaceYCCA "CMYK" -> pure JpgColorSpaceCMYK "YCcK" -> pure JpgColorSpaceYCCK [_,_,_,_] -> pure JpgColorSpaceCMYK _ -> Nothing -- | Try to decompress and decode a jpeg file. The colorspace is still -- YCbCr if you want to perform computation on the luma part. You can convert it -- to RGB using 'convertImage' from the 'ColorSpaceConvertible' typeclass. -- -- This function can output the following images: -- -- * 'ImageY8' -- -- * 'ImageYA8' -- -- * 'ImageRGB8' -- -- * 'ImageCMYK8' -- -- * 'ImageYCbCr8' -- decodeJpeg :: B.ByteString -> Either String DynamicImage decodeJpeg = fmap fst . decodeJpegWithMetadata -- | Equivalent to 'decodeJpeg' but also extracts metadatas. -- -- Extract the following metadatas from the JFIF block: -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' -- -- Exif metadata are also extracted if present. -- decodeJpegWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeJpegWithMetadata file = case runGetStrict get file of Left err -> Left err Right img -> case imgKind of Just BaseLineDCT -> let (st, arr) = decodeBaseline jfifMeta = foldMap extractMetadatas $ app0JFifMarker st exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st meta = sizeMeta <> jfifMeta <> exifMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr Just ProgressiveDCT -> let (st, arr) = decodeProgressive jfifMeta = foldMap extractMetadatas $ app0JFifMarker st exifMeta = foldMap extractTiffMetadata $ app1ExifMarker st meta = sizeMeta <> jfifMeta <> exifMeta in (, meta) <$> dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr _ -> Left "Unknown JPG kind" where compCount = length $ jpgComponents scanInfo (_,scanInfo) = gatherScanInfo img imgKind = gatherImageKind $ jpgFrame img imgWidth = fromIntegral $ jpgWidth scanInfo imgHeight = fromIntegral $ jpgHeight scanInfo sizeMeta = basicMetadata SourceJpeg imgWidth imgHeight imageSize = imgWidth * imgHeight * compCount decodeProgressive = runST $ do let (st, wrotten) = execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState Just fHdr = currentFrame st fimg <- progressiveUnpack (maximumHorizontalResolution st, maximumVerticalResolution st) fHdr (quantizationMatrices st) wrotten frozen <- unsafeFreezeImage fimg return (st, imageData frozen) decodeBaseline = 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 fImg <- decodeImage fHdr (quantizationMatrices st) wrotten wrapped frozen <- unsafeFreezeImage fImg return (st, imageData frozen) extractBlock :: forall s px. (PixelBaseComponent px ~ Word8) => Image px -- ^ Source image -> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block -> Int -- ^ Plane -> Int -- ^ X sampling factor -> Int -- ^ Y sampling factor -> Int -- ^ Sample per pixel -> Int -- ^ Block x -> Int -- ^ Block y -> ST s (MutableMacroBlock s Int16) extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src }) block 1 1 sampCount plane bx by | (bx * dctBlockSize) + 7 < w && (by * 8) + 7 < h = do let baseReadIdx = (by * dctBlockSize * w) + bx * dctBlockSize sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) val | y <- [0 .. dctBlockSize - 1] , let blockReadIdx = baseReadIdx + y * w , x <- [0 .. dctBlockSize - 1] , let val = fromIntegral $ src `VS.unsafeIndex` ((blockReadIdx + x) * sampCount + plane) ] return block extractBlock (Image { imageWidth = w, imageHeight = h, imageData = src }) block sampWidth sampHeight sampCount plane bx by = do let accessPixel x y | x < w && y < h = let idx = (y * w + x) * sampCount + plane in src `VS.unsafeIndex` idx | x >= w = accessPixel (w - 1) y | otherwise = accessPixel x (h - 1) pixelPerCoeff = fromIntegral $ sampWidth * sampHeight blockVal x y = sum [fromIntegral $ accessPixel (xBase + dx) (yBase + dy) | dy <- [0 .. sampHeight - 1] , dx <- [0 .. sampWidth - 1] ] `div` pixelPerCoeff where xBase = blockXBegin + x * sampWidth yBase = blockYBegin + y * sampHeight blockXBegin = bx * dctBlockSize * sampWidth blockYBegin = by * dctBlockSize * sampHeight sequence_ [(block `M.unsafeWrite` (y * dctBlockSize + x)) $ blockVal x y | y <- [0 .. 7], x <- [0 .. 7] ] return block serializeMacroBlock :: BoolWriteStateRef s -> HuffmanWriterCode -> HuffmanWriterCode -> MutableMacroBlock s Int32 -> ST s () serializeMacroBlock !st !dcCode !acCode !blk = (blk `M.unsafeRead` 0) >>= (fromIntegral >>> encodeDc) >> writeAcs (0, 1) >> return () where writeAcs acc@(_, 63) = (blk `M.unsafeRead` 63) >>= (fromIntegral >>> encodeAcCoefs acc) >> return () writeAcs acc@(_, i ) = (blk `M.unsafeRead` i) >>= (fromIntegral >>> encodeAcCoefs acc) >>= writeAcs encodeDc n = writeBits' st (fromIntegral code) (fromIntegral bitCount) >> when (ssss /= 0) (encodeInt st ssss n) where ssss = powerOf $ fromIntegral n (bitCount, code) = dcCode `V.unsafeIndex` fromIntegral ssss encodeAc 0 0 = writeBits' st (fromIntegral code) $ fromIntegral bitCount where (bitCount, code) = acCode `V.unsafeIndex` 0 encodeAc zeroCount n | zeroCount >= 16 = writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeAc (zeroCount - 16) n where (bitCount, code) = acCode `V.unsafeIndex` 0xF0 encodeAc zeroCount n = writeBits' st (fromIntegral code) (fromIntegral bitCount) >> encodeInt st ssss n where rrrr = zeroCount `unsafeShiftL` 4 ssss = powerOf $ fromIntegral n rrrrssss = rrrr .|. ssss (bitCount, code) = acCode `V.unsafeIndex` fromIntegral rrrrssss encodeAcCoefs ( _, 63) 0 = encodeAc 0 0 >> return (0, 64) encodeAcCoefs (zeroRunLength, i) 0 = return (zeroRunLength + 1, i + 1) encodeAcCoefs (zeroRunLength, i) n = encodeAc zeroRunLength n >> return (0, i + 1) encodeMacroBlock :: QuantificationTable -> MutableMacroBlock s Int32 -> MutableMacroBlock s Int32 -> Int16 -> MutableMacroBlock s Int16 -> ST s (Int32, MutableMacroBlock s Int32) encodeMacroBlock quantTableOfComponent workData finalData prev_dc block = do -- the inverse level shift is performed internally by the fastDCT routine blk <- fastDctLibJpeg workData block >>= zigZagReorderForward finalData >>= quantize quantTableOfComponent dc <- blk `M.unsafeRead` 0 (blk `M.unsafeWrite` 0) $ dc - fromIntegral prev_dc return (dc, blk) divUpward :: (Integral a) => a -> a -> a divUpward n dividor = val + (if rest /= 0 then 1 else 0) where (val, rest) = n `divMod` dividor prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable -> (JpgHuffmanTableSpec, HuffmanPackedTree) prepareHuffmanTable classVal dest tableDef = (JpgHuffmanTableSpec { huffmanTableClass = classVal , huffmanTableDest = dest , huffSizes = sizes , huffCodes = V.fromListN 16 [VU.fromListN (fromIntegral $ sizes ! i) lst | (i, lst) <- zip [0..] tableDef ] }, VS.singleton 0) where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef -- | Encode an image in jpeg at a reasonnable quality level. -- If you want better quality or reduced file size, you should -- use `encodeJpegAtQuality` encodeJpeg :: Image PixelYCbCr8 -> L.ByteString encodeJpeg = encodeJpegAtQuality 50 defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanPackedTree)] defaultHuffmanTables = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable ] lumaQuantTableAtQuality :: Int -> QuantificationTable lumaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultLumaQuantizationTable chromaQuantTableAtQuality :: Int -> QuantificationTable chromaQuantTableAtQuality qual = scaleQuantisationMatrix qual defaultChromaQuantizationTable zigzaggedQuantificationSpec :: Int -> [JpgQuantTableSpec] zigzaggedQuantificationSpec qual = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0, quantTable = luma } , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1, quantTable = chroma } ] where luma = zigZagReorderForwardv $ lumaQuantTableAtQuality qual chroma = zigZagReorderForwardv $ chromaQuantTableAtQuality qual -- | Function to call to encode an image to jpeg. -- The quality factor should be between 0 and 100 (100 being -- the best quality). encodeJpegAtQuality :: Word8 -- ^ Quality factor -> Image PixelYCbCr8 -- ^ Image to encode -> L.ByteString -- ^ Encoded JPEG encodeJpegAtQuality quality = encodeJpegAtQualityWithMetadata quality mempty -- | Record gathering all information to encode a component -- from the source image. Previously was a huge tuple -- burried in the code data EncoderState = EncoderState { _encComponentIndex :: !Int , _encBlockWidth :: !Int , _encBlockHeight :: !Int , _encQuantTable :: !QuantificationTable , _encDcHuffman :: !HuffmanWriterCode , _encAcHuffman :: !HuffmanWriterCode } -- | Helper type class describing all JPG-encodable pixel types class (Pixel px, PixelBaseComponent px ~ Word8) => JpgEncodable px where additionalBlocks :: Image px -> [JpgFrame] additionalBlocks _ = [] componentsOfColorSpace :: Image px -> [JpgComponent] encodingState :: Int -> Image px -> V.Vector EncoderState imageHuffmanTables :: Image px -> [(JpgHuffmanTableSpec, HuffmanPackedTree)] imageHuffmanTables _ = defaultHuffmanTables scanSpecificationOfColorSpace :: Image px -> [JpgScanSpecification] quantTableSpec :: Image px -> Int -> [JpgQuantTableSpec] quantTableSpec _ qual = take 1 $ zigzaggedQuantificationSpec qual maximumSubSamplingOf :: Image px -> Int maximumSubSamplingOf _ = 1 instance JpgEncodable Pixel8 where scanSpecificationOfColorSpace _ = [ JpgScanSpecification { componentSelector = 1 , dcEntropyCodingTable = 0 , acEntropyCodingTable = 0 } ] componentsOfColorSpace _ = [ JpgComponent { componentIdentifier = 1 , horizontalSamplingFactor = 1 , verticalSamplingFactor = 1 , quantizationTableDest = 0 } ] imageHuffmanTables _ = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable ] encodingState qual _ = V.singleton EncoderState { _encComponentIndex = 0 , _encBlockWidth = 1 , _encBlockHeight = 1 , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree } instance JpgEncodable PixelYCbCr8 where maximumSubSamplingOf _ = 2 quantTableSpec _ qual = zigzaggedQuantificationSpec qual scanSpecificationOfColorSpace _ = [ JpgScanSpecification { componentSelector = 1 , dcEntropyCodingTable = 0 , acEntropyCodingTable = 0 } , JpgScanSpecification { componentSelector = 2 , dcEntropyCodingTable = 1 , acEntropyCodingTable = 1 } , JpgScanSpecification { componentSelector = 3 , dcEntropyCodingTable = 1 , acEntropyCodingTable = 1 } ] componentsOfColorSpace _ = [ JpgComponent { componentIdentifier = 1 , horizontalSamplingFactor = 2 , verticalSamplingFactor = 2 , quantizationTableDest = 0 } , JpgComponent { componentIdentifier = 2 , horizontalSamplingFactor = 1 , verticalSamplingFactor = 1 , quantizationTableDest = 1 } , JpgComponent { componentIdentifier = 3 , horizontalSamplingFactor = 1 , verticalSamplingFactor = 1 , quantizationTableDest = 1 } ] encodingState qual _ = V.fromListN 3 [lumaState, chromaState, chromaState { _encComponentIndex = 2 }] where lumaState = EncoderState { _encComponentIndex = 0 , _encBlockWidth = 2 , _encBlockHeight = 2 , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree } chromaState = EncoderState { _encComponentIndex = 1 , _encBlockWidth = 1 , _encBlockHeight = 1 , _encQuantTable = zigZagReorderForwardv $ chromaQuantTableAtQuality qual , _encDcHuffman = makeInverseTable defaultDcChromaHuffmanTree , _encAcHuffman = makeInverseTable defaultAcChromaHuffmanTree } instance JpgEncodable PixelRGB8 where additionalBlocks _ = [] where _adobe14 = JpgAdobeApp14 { _adobeDctVersion = 100 , _adobeFlag0 = 0 , _adobeFlag1 = 0 , _adobeTransform = AdobeUnknown } imageHuffmanTables _ = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable ] scanSpecificationOfColorSpace _ = fmap build "RGB" where build c = JpgScanSpecification { componentSelector = fromIntegral $ fromEnum c , dcEntropyCodingTable = 0 , acEntropyCodingTable = 0 } componentsOfColorSpace _ = fmap build "RGB" where build c = JpgComponent { componentIdentifier = fromIntegral $ fromEnum c , horizontalSamplingFactor = 1 , verticalSamplingFactor = 1 , quantizationTableDest = 0 } encodingState qual _ = V.fromListN 3 $ fmap build [0 .. 2] where build ix = EncoderState { _encComponentIndex = ix , _encBlockWidth = 1 , _encBlockHeight = 1 , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree } instance JpgEncodable PixelCMYK8 where additionalBlocks _ = [] where _adobe14 = JpgAdobeApp14 { _adobeDctVersion = 100 , _adobeFlag0 = 32768 , _adobeFlag1 = 0 , _adobeTransform = AdobeYCck } imageHuffmanTables _ = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable ] scanSpecificationOfColorSpace _ = fmap build "CMYK" where build c = JpgScanSpecification { componentSelector = fromIntegral $ fromEnum c , dcEntropyCodingTable = 0 , acEntropyCodingTable = 0 } componentsOfColorSpace _ = fmap build "CMYK" where build c = JpgComponent { componentIdentifier = fromIntegral $ fromEnum c , horizontalSamplingFactor = 1 , verticalSamplingFactor = 1 , quantizationTableDest = 0 } encodingState qual _ = V.fromListN 4 $ fmap build [0 .. 3] where build ix = EncoderState { _encComponentIndex = ix , _encBlockWidth = 1 , _encBlockHeight = 1 , _encQuantTable = zigZagReorderForwardv $ lumaQuantTableAtQuality qual , _encDcHuffman = makeInverseTable defaultDcLumaHuffmanTree , _encAcHuffman = makeInverseTable defaultAcLumaHuffmanTree } -- | Equivalent to 'encodeJpegAtQuality', but will store the following -- metadatas in the file using a JFIF block: -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' -- encodeJpegAtQualityWithMetadata :: Word8 -- ^ Quality factor -> Metadatas -> Image PixelYCbCr8 -- ^ Image to encode -> L.ByteString -- ^ Encoded JPEG encodeJpegAtQualityWithMetadata = encodeDirectJpegAtQualityWithMetadata -- | Equivalent to 'encodeJpegAtQuality', but will store the following -- metadatas in the file using a JFIF block: -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' -- -- This function also allow to create JPEG files with the following color -- space: -- -- * Y ('Pixel8') for greyscale. -- * RGB ('PixelRGB8') with no color downsampling on any plane -- * CMYK ('PixelCMYK8') with no color downsampling on any plane -- encodeDirectJpegAtQualityWithMetadata :: forall px. (JpgEncodable px) => Word8 -- ^ Quality factor -> Metadatas -> Image px -- ^ Image to encode -> L.ByteString -- ^ Encoded JPEG encodeDirectJpegAtQualityWithMetadata quality metas img = encode finalImage where !w = imageWidth img !h = imageHeight img finalImage = JpgImage $ encodeMetadatas metas ++ additionalBlocks img ++ [ JpgQuantTable $ quantTableSpec img (fromIntegral quality) , JpgScans JpgBaselineDCTHuffman hdr , JpgHuffmanTable $ imageHuffmanTables img , JpgScanBlob scanHeader encodedImage ] !outputComponentCount = componentCount (undefined :: px) scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } scanHeader' = JpgScanHeader { scanLength = 0 , scanComponentCount = fromIntegral outputComponentCount , scans = scanSpecificationOfColorSpace img , spectralSelection = (0, 63) , successiveApproxHigh = 0 , successiveApproxLow = 0 } hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } hdr' = JpgFrameHeader { jpgFrameHeaderLength = 0 , jpgSamplePrecision = 8 , jpgHeight = fromIntegral h , jpgWidth = fromIntegral w , jpgImageComponentCount = fromIntegral outputComponentCount , jpgComponents = componentsOfColorSpace img } !maxSampling = maximumSubSamplingOf img !horizontalMetaBlockCount = w `divUpward` (dctBlockSize * maxSampling) !verticalMetaBlockCount = h `divUpward` (dctBlockSize * maxSampling) !componentDef = encodingState (fromIntegral quality) img encodedImage = runST $ do dc_table <- M.replicate outputComponentCount 0 block <- createEmptyMutableMacroBlock workData <- createEmptyMutableMacroBlock zigzaged <- createEmptyMutableMacroBlock writeState <- newWriteStateRef rasterMap horizontalMetaBlockCount verticalMetaBlockCount $ \mx my -> V.forM_ componentDef $ \(EncoderState comp sizeX sizeY table dc ac) -> let !xSamplingFactor = maxSampling - sizeX + 1 !ySamplingFactor = maxSampling - sizeY + 1 !extractor = extractBlock img block xSamplingFactor ySamplingFactor outputComponentCount in rasterMap sizeX sizeY $ \subX subY -> do let !blockY = my * sizeY + subY !blockX = mx * sizeX + subX prev_dc <- dc_table `M.unsafeRead` comp extracted <- extractor comp blockX blockY (dc_coeff, neo_block) <- encodeMacroBlock table workData zigzaged prev_dc extracted (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff serializeMacroBlock writeState dc ac neo_block finalizeBoolWriter writeState JuicyPixels-3.2.8/src/Codec/Picture/HDR.hs0000644000000000000000000004443512763010461016364 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TupleSections #-} -- | Module dedicated of Radiance file decompression (.hdr or .pic) file. -- Radiance file format is used for High dynamic range imaging. module Codec.Picture.HDR( decodeHDR , decodeHDRWithMetadata , encodeHDR , encodeRawHDR , encodeRLENewStyleHDR , writeHDR , writeRLENewStyleHDR ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<*>), (<$>) ) #endif import Data.Bits( Bits, (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.Char( ord, chr, isDigit ) import Data.Word( Word8 ) import Data.Monoid( (<>) ) import Control.Monad( when, foldM, foldM_, forM, forM_, unless ) import Control.Monad.Trans.Class( lift ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Char8 as BC import Data.List( partition ) import Data.Binary( Binary( .. ), encode ) import Data.Binary.Get( Get, getByteString, getWord8 ) import Data.Binary.Put( putByteString, putLazyByteString ) import Control.Monad.ST( ST, runST ) import Foreign.Storable ( Storable ) import Control.Monad.Primitive ( PrimState, PrimMonad ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.Metadata( Metadatas , SourceFormat( SourceHDR ) , basicMetadata ) import Codec.Picture.InternalHelper import Codec.Picture.Types import Codec.Picture.VectorByteConversion #if MIN_VERSION_transformers(0, 4, 0) import Control.Monad.Trans.Except( ExceptT, throwE, runExceptT ) #else -- Transfomers 0.3 compat import Control.Monad.Trans.Error( Error, ErrorT, throwError, runErrorT ) type ExceptT = ErrorT throwE :: (Monad m, Error e) => e -> ErrorT e m a throwE = throwError runExceptT :: ErrorT e m a -> m (Either e a) runExceptT = runErrorT #endif {-# INLINE (.<<.) #-} (.<<.), (.>>.) :: (Bits a) => a -> Int -> a (.<<.) = unsafeShiftL (.>>.) = unsafeShiftR {-# INLINE (.<-.) #-} (.<-.) :: (PrimMonad m, Storable a) => M.STVector (PrimState m) a -> Int -> a -> m () (.<-.) = M.write {-M.unsafeWrite-} type HDRReader s a = ExceptT String (ST s) a data RGBE = RGBE !Word8 !Word8 !Word8 !Word8 instance Binary RGBE where put (RGBE r g b e) = put r >> put g >> put b >> put e get = RGBE <$> get <*> get <*> get <*> get checkLineLength :: RGBE -> Int checkLineLength (RGBE _ _ a b) = (fromIntegral a .<<. 8) .|. fromIntegral b isNewRunLengthMarker :: RGBE -> Bool isNewRunLengthMarker (RGBE 2 2 _ _) = True isNewRunLengthMarker _ = False data RadianceFormat = FormatRGBE | FormatXYZE radiance32bitRleRGBEFormat, radiance32bitRleXYZEFromat :: B.ByteString radiance32bitRleRGBEFormat = BC.pack "32-bit_rle_rgbe" radiance32bitRleXYZEFromat = BC.pack "32-bit_rle_xyze" instance Binary RadianceFormat where put FormatRGBE = putByteString radiance32bitRleRGBEFormat put FormatXYZE = putByteString radiance32bitRleXYZEFromat get = getByteString (B.length radiance32bitRleRGBEFormat) >>= format where format sig | sig == radiance32bitRleRGBEFormat = pure FormatRGBE | sig == radiance32bitRleXYZEFromat = pure FormatXYZE | otherwise = fail "Unrecognized Radiance format" toRGBE :: PixelRGBF -> RGBE toRGBE (PixelRGBF r g b) | d <= 1e-32 = RGBE 0 0 0 0 | otherwise = RGBE (fix r) (fix g) (fix b) (fromIntegral $ e + 128) where d = maximum [r, g, b] e = exponent d coeff = significand d * 255.9999 / d fix v = truncate $ v * coeff dropUntil :: Word8 -> Get () dropUntil c = getWord8 >>= inner where inner val | val == c = pure () inner _ = getWord8 >>= inner getUntil :: (Word8 -> Bool) -> B.ByteString -> Get B.ByteString getUntil f initialAcc = getWord8 >>= inner initialAcc where inner acc c | f c = pure acc inner acc c = getWord8 >>= inner (B.snoc acc c) data RadianceHeader = RadianceHeader { radianceInfos :: [(B.ByteString, B.ByteString)] , radianceFormat :: RadianceFormat , radianceHeight :: !Int , radianceWidth :: !Int , radianceData :: L.ByteString } radianceFileSignature :: B.ByteString radianceFileSignature = BC.pack "#?RADIANCE\n" unpackColor :: L.ByteString -> Int -> RGBE unpackColor str idx = RGBE (at 0) (at 1) (at 2) (at 3) where at n = L.index str . fromIntegral $ idx + n storeColor :: M.STVector s Word8 -> Int -> RGBE -> ST s () storeColor vec idx (RGBE r g b e) = do (vec .<-. (idx + 0)) r (vec .<-. (idx + 1)) g (vec .<-. (idx + 2)) b (vec .<-. (idx + 3)) e parsePair :: Char -> Get (B.ByteString, B.ByteString) parsePair firstChar = do let eol c = c == fromIntegral (ord '\n') line <- getUntil eol B.empty case BC.split '=' line of [] -> pure (BC.singleton firstChar, B.empty) [val] -> pure (BC.singleton firstChar, val) [key, val] -> pure (BC.singleton firstChar <> key, val) (key : vals) -> pure (BC.singleton firstChar <> key, B.concat vals) decodeInfos :: Get [(B.ByteString, B.ByteString)] decodeInfos = do char <- getChar8 case char of -- comment '#' -> dropUntil (fromIntegral $ ord '\n') >> decodeInfos -- end of header, no more information '\n' -> pure [] -- Classical parsing c -> (:) <$> parsePair c <*> decodeInfos -- | Decode an HDR (radiance) image, the resulting image can be: -- -- * 'ImageRGBF' -- decodeHDR :: B.ByteString -> Either String DynamicImage decodeHDR = fmap fst . decodeHDRWithMetadata -- | Equivalent to decodeHDR but with aditional metadatas. decodeHDRWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeHDRWithMetadata str = runST $ runExceptT $ case runGet decodeHeader $ L.fromChunks [str] of Left err -> throwE err Right rez -> let meta = basicMetadata SourceHDR (abs $ radianceWidth rez) (abs $ radianceHeight rez) in (, meta) . ImageRGBF <$> (decodeRadiancePicture rez >>= lift . unsafeFreezeImage) getChar8 :: Get Char getChar8 = chr . fromIntegral <$> getWord8 isSign :: Char -> Bool isSign c = c == '+' || c == '-' isAxisLetter :: Char -> Bool isAxisLetter c = c == 'X' || c == 'Y' decodeNum :: Get Int decodeNum = do sign <- getChar8 letter <- getChar8 space <- getChar8 unless (isSign sign && isAxisLetter letter && space == ' ') (fail "Invalid radiance size declaration") let numDec acc c | isDigit c = getChar8 >>= numDec (acc * 10 + ord c - ord '0') numDec acc _ | sign == '-' = pure $ negate acc | otherwise = pure acc getChar8 >>= numDec 0 copyPrevColor :: M.STVector s Word8 -> Int -> ST s () copyPrevColor scanLine idx = do r <- scanLine `M.unsafeRead` (idx - 4) g <- scanLine `M.unsafeRead` (idx - 3) b <- scanLine `M.unsafeRead` (idx - 2) e <- scanLine `M.unsafeRead` (idx - 1) (scanLine `M.unsafeWrite` (idx + 0)) r (scanLine `M.unsafeWrite` (idx + 1)) g (scanLine `M.unsafeWrite` (idx + 2)) b (scanLine `M.unsafeWrite` (idx + 3)) e oldStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 -> HDRReader s Int oldStyleRLE inputData initialIdx scanLine = inner initialIdx 0 0 where maxOutput = M.length scanLine maxInput = fromIntegral $ L.length inputData inner readIdx writeIdx _ | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx inner readIdx writeIdx shift = do let color@(RGBE r g b e) = unpackColor inputData readIdx isRun = r == 1 && g == 1 && b == 1 if not isRun then do lift $ storeColor scanLine writeIdx color inner (readIdx + 4) (writeIdx + 4) 0 else do let count = fromIntegral e .<<. shift lift $ forM_ [0 .. count] $ \i -> copyPrevColor scanLine (writeIdx + 4 * i) inner (readIdx + 4) (writeIdx + 4 * count) (shift + 8) newStyleRLE :: L.ByteString -> Int -> M.STVector s Word8 -> HDRReader s Int newStyleRLE inputData initialIdx scanline = foldM inner initialIdx [0 .. 3] where dataAt idx | fromIntegral idx >= maxInput = throwE $ "Read index out of bound (" ++ show idx ++ ")" | otherwise = pure $ L.index inputData (fromIntegral idx) maxOutput = M.length scanline maxInput = fromIntegral $ L.length inputData stride = 4 strideSet count destIndex _ | endIndex > maxOutput + stride = throwE $ "Out of bound HDR scanline " ++ show endIndex ++ " (max " ++ show maxOutput ++ ")" where endIndex = destIndex + count * stride strideSet count destIndex val = aux destIndex count where aux i 0 = pure i aux i c = do lift $ (scanline .<-. i) val aux (i + stride) (c - 1) strideCopy _ count destIndex | writeEndBound > maxOutput + stride = throwE "Out of bound HDR scanline" where writeEndBound = destIndex + count * stride strideCopy sourceIndex count destIndex = aux sourceIndex destIndex count where aux _ j 0 = pure j aux i j c = do val <- dataAt i lift $ (scanline .<-. j) val aux (i + 1) (j + stride) (c - 1) inner readIdx writeIdx | readIdx >= maxInput || writeIdx >= maxOutput = pure readIdx inner readIdx writeIdx = do code <- dataAt readIdx if code > 128 then do let repeatCount = fromIntegral code .&. 0x7F newVal <- dataAt $ readIdx + 1 endIndex <- strideSet repeatCount writeIdx newVal inner (readIdx + 2) endIndex else do let iCode = fromIntegral code endIndex <- strideCopy (readIdx + 1) iCode writeIdx inner (readIdx + iCode + 1) endIndex instance Binary RadianceHeader where get = decodeHeader put hdr = do putByteString radianceFileSignature putByteString $ BC.pack "FORMAT=" put $ radianceFormat hdr let sizeString = BC.pack $ "\n\n-Y " ++ show (radianceHeight hdr) ++ " +X " ++ show (radianceWidth hdr) ++ "\n" putByteString sizeString putLazyByteString $ radianceData hdr decodeHeader :: Get RadianceHeader decodeHeader = do sig <- getByteString $ B.length radianceFileSignature when (sig /= radianceFileSignature) (fail "Invalid radiance file signature") infos <- decodeInfos let formatKey = BC.pack "FORMAT" case partition (\(k,_) -> k /= formatKey) infos of (_, []) -> fail "No radiance format specified" (info, [(_, formatString)]) -> case runGet get $ L.fromChunks [formatString] of Left err -> fail err Right format -> do (n1, n2, b) <- (,,) <$> decodeNum <*> decodeNum <*> getRemainingBytes return . RadianceHeader info format n1 n2 $ L.fromChunks [b] _ -> fail "Multiple radiance format specified" toFloat :: RGBE -> PixelRGBF toFloat (RGBE r g b e) = PixelRGBF rf gf bf where f = encodeFloat 1 $ fromIntegral e - (128 + 8) rf = (fromIntegral r + 0.0) * f gf = (fromIntegral g + 0.0) * f bf = (fromIntegral b + 0.0) * f encodeScanlineColor :: M.STVector s Word8 -> M.STVector s Word8 -> Int -> ST s Int encodeScanlineColor vec outVec outIdx = do val <- vec `M.unsafeRead` 0 runLength 1 0 val 1 outIdx where maxIndex = M.length vec pushRun len val at = do (outVec `M.unsafeWrite` at) $ fromIntegral $ len .|. 0x80 (outVec `M.unsafeWrite` (at + 1)) val return $ at + 2 pushData start len at = do (outVec `M.unsafeWrite` at) $ fromIntegral len let first = start - len end = start - 1 offset = at - first + 1 forM_ [first .. end] $ \i -> do v <- vec `M.unsafeRead` i (outVec `M.unsafeWrite` (offset + i)) v return $ at + len + 1 -- End of scanline, empty the thing runLength run cpy prev idx at | idx >= maxIndex = case (run, cpy) of (0, 0) -> pure at (0, n) -> pushData idx n at (n, 0) -> pushRun n prev at (_, _) -> error "HDR - Run length algorithm is wrong" -- full runlength, we must write the packet runLength r@127 _ prev idx at = do val <- vec `M.unsafeRead` idx pushRun r prev at >>= runLength 1 0 val (idx + 1) -- full copy, we must write the packet runLength _ c@127 _ idx at = do val <- vec `M.unsafeRead` idx pushData idx c at >>= runLength 1 0 val (idx + 1) runLength n 0 prev idx at = do val <- vec `M.unsafeRead` idx case val == prev of True -> runLength (n + 1) 0 prev (idx + 1) at False | n < 4 -> runLength 0 (n + 1) val (idx + 1) at False -> pushRun n prev at >>= runLength 1 0 val (idx + 1) runLength 0 n prev idx at = do val <- vec `M.unsafeRead` idx if val /= prev then runLength 0 (n + 1) val (idx + 1) at else pushData (idx - 1) (n - 1) at >>= runLength (2 :: Int) 0 val (idx + 1) runLength _ _ _ _ _ = error "HDR RLE inconsistent state" -- | Write an High dynamic range image into a radiance -- image file on disk. writeHDR :: FilePath -> Image PixelRGBF -> IO () writeHDR filename img = L.writeFile filename $ encodeHDR img -- | Write a RLE encoded High dynamic range image into a radiance -- image file on disk. writeRLENewStyleHDR :: FilePath -> Image PixelRGBF -> IO () writeRLENewStyleHDR filename img = L.writeFile filename $ encodeRLENewStyleHDR img -- | Encode an High dynamic range image into a radiance image -- file format. -- Alias for encodeRawHDR encodeHDR :: Image PixelRGBF -> L.ByteString encodeHDR = encodeRawHDR -- | Encode an High dynamic range image into a radiance image -- file format. without compression encodeRawHDR :: Image PixelRGBF -> L.ByteString encodeRawHDR pic = encode descriptor where newImage = pixelMap rgbeInRgba pic -- we are cheating to death here, the layout we want -- correspond to the layout of pixelRGBA8, so we -- convert rgbeInRgba pixel = PixelRGBA8 r g b e where RGBE r g b e = toRGBE pixel descriptor = RadianceHeader { radianceInfos = [] , radianceFormat = FormatRGBE , radianceHeight = imageHeight pic , radianceWidth = imageWidth pic , radianceData = L.fromChunks [toByteString $ imageData newImage] } -- | Encode an High dynamic range image into a radiance image -- file format using a light RLE compression. Some problems -- seem to arise with some image viewer. encodeRLENewStyleHDR :: Image PixelRGBF -> L.ByteString encodeRLENewStyleHDR pic = encode $ runST $ do let w = imageWidth pic h = imageHeight pic scanLineR <- M.new w :: ST s (M.STVector s Word8) scanLineG <- M.new w scanLineB <- M.new w scanLineE <- M.new w encoded <- forM [0 .. h - 1] $ \line -> do buff <- M.new $ w * 4 + w `div` 127 + 2 let columner col | col >= w = return () columner col = do let RGBE r g b e = toRGBE $ pixelAt pic col line (scanLineR `M.unsafeWrite` col) r (scanLineG `M.unsafeWrite` col) g (scanLineB `M.unsafeWrite` col) b (scanLineE `M.unsafeWrite` col) e columner (col + 1) columner 0 (buff `M.unsafeWrite` 0) 2 (buff `M.unsafeWrite` 1) 2 (buff `M.unsafeWrite` 2) $ fromIntegral ((w .>>. 8) .&. 0xFF) (buff `M.unsafeWrite` 3) $ fromIntegral (w .&. 0xFF) i1 <- encodeScanlineColor scanLineR buff 4 i2 <- encodeScanlineColor scanLineG buff i1 i3 <- encodeScanlineColor scanLineB buff i2 endIndex <- encodeScanlineColor scanLineE buff i3 (\v -> blitVector v 0 endIndex) <$> V.unsafeFreeze buff pure RadianceHeader { radianceInfos = [] , radianceFormat = FormatRGBE , radianceHeight = h , radianceWidth = w , radianceData = L.fromChunks encoded } decodeRadiancePicture :: RadianceHeader -> HDRReader s (MutableImage s PixelRGBF) decodeRadiancePicture hdr = do let width = abs $ radianceWidth hdr height = abs $ radianceHeight hdr packedData = radianceData hdr scanLine <- lift $ M.new $ width * 4 resultBuffer <- lift $ M.new $ width * height * 3 let scanLineImage = MutableImage { mutableImageWidth = width , mutableImageHeight = 1 , mutableImageData = scanLine } finalImage = MutableImage { mutableImageWidth = width , mutableImageHeight = height , mutableImageData = resultBuffer } let scanLineExtractor readIdx line = do let color = unpackColor packedData readIdx inner | isNewRunLengthMarker color = do let calcSize = checkLineLength color when (calcSize /= width) (throwE "Invalid sanline size") pure $ \idx -> newStyleRLE packedData (idx + 4) | otherwise = pure $ oldStyleRLE packedData f <- inner newRead <- f readIdx scanLine forM_ [0 .. width - 1] $ \i -> do -- mokay, it's a hack, but I don't want to define a -- pixel instance of RGBE... PixelRGBA8 r g b e <- lift $ readPixel scanLineImage i 0 lift $ writePixel finalImage i line . toFloat $ RGBE r g b e return newRead foldM_ scanLineExtractor 0 [0 .. height - 1] return finalImage JuicyPixels-3.2.8/src/Codec/Picture/Tga.hs0000644000000000000000000004176612763046173016477 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE CPP #-} -- | Module implementing function to read and write -- Targa (*.tga) files. module Codec.Picture.Tga( decodeTga , decodeTgaWithMetadata , decodeTgaWithPaletteAndMetadata , TgaSaveable , encodeTga , writeTga ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) import Control.Applicative( (<*>), pure, (<$>) ) #endif import Control.Arrow( first ) import Control.Monad.ST( ST, runST ) import Data.Bits( (.&.) , (.|.) , bit , testBit , setBit , unsafeShiftL , unsafeShiftR ) 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.Metadata( Metadatas , SourceFormat( SourceTGA ) , basicMetadata ) 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 = 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 ++ ")" toPaletted :: (Pixel px) => (Image Pixel8 -> Palette' px -> PalettedImage) -> Image px -> DynamicImage -> Either String PalettedImage toPaletted f palette (ImageY8 img) = pure $ f img pal where pal = Palette' { _paletteSize = imageWidth palette , _paletteData = imageData palette } toPaletted _ _ _ = fail "Bad colorspace for image" unparse :: TgaFile -> Either String (PalettedImage, Metadatas) 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 metas = basicMetadata SourceTGA (_tgaHdrWidth hdr) (_tgaHdrHeight hdr) 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 _ -> fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker ImageTypeMonochrome _ -> fmap ((, metas) . TrueColorImage) $ prepareUnpacker file unpacker ImageTypeColorMapped _ -> case decodedPalette of Left str -> Left str Right (TrueColorImage (ImageY8 img), _) -> fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedY8 img Right (TrueColorImage (ImageRGB8 img), _) -> fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGB8 img Right (TrueColorImage (ImageRGBA8 img), _) -> fmap (, metas) $ prepareUnpacker file unpacker >>= toPaletted PalettedRGBA8 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 images: -- -- * 'ImageY8' -- -- * 'ImageRGB8' -- -- * 'ImageRGBA8' -- decodeTga :: B.ByteString -> Either String DynamicImage decodeTga byte = fst <$> decodeTgaWithMetadata byte -- | Equivalent to decodeTga but also provide metadata decodeTgaWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeTgaWithMetadata byte = first palettedToTrueColor <$> decodeTgaWithPaletteAndMetadata byte -- | Equivalent to decodeTga but with metdata and palette if any decodeTgaWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeTgaWithPaletteAndMetadata 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 } {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/Tiff.hs0000644000000000000000000010756712763046173016656 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} -- | Module implementing TIFF decoding. -- -- Supported compression schemes: -- -- * Uncompressed -- -- * PackBits -- -- * LZW -- -- Supported bit depth: -- -- * 2 bits -- -- * 4 bits -- -- * 8 bits -- -- * 16 bits -- module Codec.Picture.Tiff( decodeTiff , decodeTiffWithMetadata , decodeTiffWithPaletteAndMetadata , TiffSaveable , encodeTiff , writeTiff ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>), (<*>), pure ) import Data.Monoid( mempty ) #endif import Control.Arrow( first ) import Control.Monad( when, foldM_, unless, forM_ ) import Control.Monad.ST( ST, runST ) import Control.Monad.Writer.Strict( execWriter, tell, Writer ) import Data.Int( Int8 ) import Data.Word( Word8, Word16, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) import Data.Binary.Get( Get ) import Data.Binary.Put( runPut ) import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as Lb import qualified Data.ByteString.Unsafe as BU import Foreign.Storable( sizeOf ) import Codec.Picture.Metadata.Exif import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types import Codec.Picture.Gif.LZW import Codec.Picture.Tiff.Types import Codec.Picture.Tiff.Metadata import Codec.Picture.VectorByteConversion( toByteString ) data TiffInfo = TiffInfo { tiffHeader :: TiffHeader , tiffWidth :: Word32 , tiffHeight :: Word32 , tiffColorspace :: TiffColorspace , tiffSampleCount :: Word32 , tiffRowPerStrip :: Word32 , tiffPlaneConfiguration :: TiffPlanarConfiguration , tiffSampleFormat :: [TiffSampleFormat] , tiffBitsPerSample :: V.Vector Word32 , tiffCompression :: TiffCompression , tiffStripSize :: V.Vector Word32 , tiffOffsets :: V.Vector Word32 , tiffPalette :: Maybe (Image PixelRGB16) , tiffYCbCrSubsampling :: V.Vector Word32 , tiffExtraSample :: Maybe ExtraSample , tiffPredictor :: Predictor , tiffMetadatas :: Metadatas } unLong :: String -> ExifData -> Get (V.Vector Word32) unLong _ (ExifShorts v) = pure $ V.map fromIntegral v unLong _ (ExifLongs v) = pure v unLong errMessage _ = fail errMessage findIFD :: String -> ExifTag -> [ImageFileDirectory] -> Get ImageFileDirectory findIFD errorMessage tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> fail errorMessage (x:_) -> pure x findPalette :: [ImageFileDirectory] -> Get (Maybe (Image PixelRGB16)) findPalette ifds = case [v | v <- ifds, ifdIdentifier v == TagColorMap] of (ImageFileDirectory { ifdExtended = ExifShorts vec }:_) -> pure . Just . Image pixelCount 1 $ VS.generate (V.length vec) axx where pixelCount = V.length vec `div` 3 axx v = vec `V.unsafeIndex` (idx + color * pixelCount) where (idx, color) = v `divMod` 3 _ -> pure Nothing findIFDData :: String -> ExifTag -> [ImageFileDirectory] -> Get Word32 findIFDData msg tag lst = ifdOffset <$> findIFD msg tag lst findIFDDefaultData :: Word32 -> ExifTag -> [ImageFileDirectory] -> Get Word32 findIFDDefaultData d tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> pure d (x:_) -> pure $ ifdOffset x findIFDExt :: String -> ExifTag -> [ImageFileDirectory] -> Get ExifData findIFDExt msg tag lst = do val <- findIFD msg tag lst case val of ImageFileDirectory { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> pure . ExifShorts . V.singleton $ fromIntegral ofs ImageFileDirectory { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> pure . ExifLongs . V.singleton $ fromIntegral ofs ImageFileDirectory { ifdExtended = v } -> pure v findIFDExtDefaultData :: [Word32] -> ExifTag -> [ImageFileDirectory] -> Get [Word32] findIFDExtDefaultData d tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> pure d (ImageFileDirectory { ifdExtended = ExifNone }:_) -> return d (x:_) -> V.toList <$> unLong errorMessage (ifdExtended x) where errorMessage = "Can't parse tag " ++ show tag ++ " " ++ show (ifdExtended x) -- It's temporary, remove once tiff decoding is better -- handled. {- instance Show (Image PixelRGB16) where show _ = "Image PixelRGB16" -} copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int copyByteString str vec stride startWrite (from, count) = inner startWrite fromi where fromi = fromIntegral from maxi = fromi + fromIntegral count inner writeIdx i | i >= maxi = pure writeIdx inner writeIdx i = do let v = str `BU.unsafeIndex` i (vec `M.unsafeWrite` writeIdx) v inner (writeIdx + stride) $ i + 1 unpackPackBit :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int unpackPackBit str outVec stride writeIndex (offset, size) = loop fromi writeIndex where fromi = fromIntegral offset maxi = fromi + fromIntegral size replicateByte writeIdx _ 0 = pure writeIdx replicateByte writeIdx v count = do (outVec `M.unsafeWrite` writeIdx) v replicateByte (writeIdx + stride) v $ count - 1 loop i writeIdx | i >= maxi = pure writeIdx loop i writeIdx = choice {-where v = fromIntegral (str `BU.unsafeIndex` i) :: Int8-} where v = fromIntegral (str `B.index` i) :: Int8 choice -- data | 0 <= v = copyByteString str outVec stride writeIdx (fromIntegral $ i + 1, fromIntegral v + 1) >>= loop (i + 2 + fromIntegral v) -- run | -127 <= v = do {-let nextByte = str `BU.unsafeIndex` (i + 1)-} let nextByte = str `B.index` (i + 1) count = negate (fromIntegral v) + 1 :: Int replicateByte writeIdx nextByte count >>= loop (i + 2) -- noop | otherwise = loop writeIdx $ i + 1 uncompressAt :: TiffCompression -> B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int uncompressAt CompressionNone = copyByteString uncompressAt CompressionPackBit = unpackPackBit uncompressAt CompressionLZW = \str outVec _stride writeIndex (offset, size) -> do let toDecode = B.take (fromIntegral size) $ B.drop (fromIntegral offset) str runBoolReader $ decodeLzwTiff toDecode outVec writeIndex return 0 uncompressAt _ = error "Unhandled compression" class Unpackable a where type StorageType a :: * outAlloc :: a -> Int -> ST s (M.STVector s (StorageType a)) -- | Final image and size, return offset and vector allocTempBuffer :: a -> M.STVector s (StorageType a) -> Int -> ST s (M.STVector s Word8) offsetStride :: a -> Int -> Int -> (Int, Int) mergeBackTempBuffer :: a -- ^ Type witness, just for the type checker. -> Endianness -> M.STVector s Word8 -- ^ Temporary buffer handling decompression. -> Int -- ^ Line size in pixels -> Int -- ^ Write index, in bytes -> Word32 -- ^ size, in bytes -> Int -- ^ Stride -> M.STVector s (StorageType a) -- ^ Final buffer -> ST s () -- | The Word8 instance is just a passthrough, to avoid -- copying memory twice instance Unpackable Word8 where type StorageType Word8 = Word8 offsetStride _ i stride = (i, stride) allocTempBuffer _ buff _ = pure buff mergeBackTempBuffer _ _ _ _ _ _ _ _ = pure () outAlloc _ count = M.replicate count 0 -- M.new instance Unpackable Word16 where type StorageType Word16 = Word16 offsetStride _ _ _ = (0, 1) outAlloc _ = M.new allocTempBuffer _ _ s = M.new $ s * 2 mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = looperLe index 0 where looperLe _ readIndex | readIndex >= fromIntegral size = pure () looperLe writeIndex readIndex = do v1 <- tempVec `M.read` readIndex v2 <- tempVec `M.read` (readIndex + 1) let finalValue = (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1 (outVec `M.write` writeIndex) finalValue looperLe (writeIndex + stride) (readIndex + 2) mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = looperBe index 0 where looperBe _ readIndex | readIndex >= fromIntegral size = pure () looperBe writeIndex readIndex = do v1 <- tempVec `M.read` readIndex v2 <- tempVec `M.read` (readIndex + 1) let finalValue = (fromIntegral v1 `unsafeShiftL` 8) .|. fromIntegral v2 (outVec `M.write` writeIndex) finalValue looperBe (writeIndex + stride) (readIndex + 2) instance Unpackable Word32 where type StorageType Word32 = Word32 offsetStride _ _ _ = (0, 1) outAlloc _ = M.new allocTempBuffer _ _ s = M.new $ s * 4 mergeBackTempBuffer _ EndianLittle tempVec _ index size stride outVec = looperLe index 0 where looperLe _ readIndex | readIndex >= fromIntegral size = pure () looperLe writeIndex readIndex = do v1 <- tempVec `M.read` readIndex v2 <- tempVec `M.read` (readIndex + 1) v3 <- tempVec `M.read` (readIndex + 2) v4 <- tempVec `M.read` (readIndex + 3) let finalValue = (fromIntegral v4 `unsafeShiftL` 24) .|. (fromIntegral v3 `unsafeShiftL` 16) .|. (fromIntegral v2 `unsafeShiftL` 8) .|. fromIntegral v1 (outVec `M.write` writeIndex) finalValue looperLe (writeIndex + stride) (readIndex + 4) mergeBackTempBuffer _ EndianBig tempVec _ index size stride outVec = looperBe index 0 where looperBe _ readIndex | readIndex >= fromIntegral size = pure () looperBe writeIndex readIndex = do v1 <- tempVec `M.read` readIndex v2 <- tempVec `M.read` (readIndex + 1) v3 <- tempVec `M.read` (readIndex + 2) v4 <- tempVec `M.read` (readIndex + 3) let finalValue = (fromIntegral v1 `unsafeShiftL` 24) .|. (fromIntegral v2 `unsafeShiftL` 16) .|. (fromIntegral v3 `unsafeShiftL` 8) .|. fromIntegral v4 (outVec `M.write` writeIndex) finalValue looperBe (writeIndex + stride) (readIndex + 4) data Pack4 = Pack4 instance Unpackable Pack4 where type StorageType Pack4 = Word8 allocTempBuffer _ _ = M.new offsetStride _ _ _ = (0, 1) outAlloc _ = M.new mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = inner 0 index pxCount where pxCount = lineSize `div` stride maxWrite = M.length outVec inner readIdx writeIdx _ | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () inner readIdx writeIdx line | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount inner readIdx writeIdx line = do v <- tempVec `M.read` readIdx let high = (v `unsafeShiftR` 4) .&. 0xF low = v .&. 0xF (outVec `M.write` writeIdx) high when (writeIdx + stride < maxWrite) $ (outVec `M.write` (writeIdx + stride)) low inner (readIdx + 1) (writeIdx + 2 * stride) (line - 2) data Pack2 = Pack2 instance Unpackable Pack2 where type StorageType Pack2 = Word8 allocTempBuffer _ _ = M.new offsetStride _ _ _ = (0, 1) outAlloc _ = M.new mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = inner 0 index pxCount where pxCount = lineSize `div` stride maxWrite = M.length outVec inner readIdx writeIdx _ | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () inner readIdx writeIdx line | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount inner readIdx writeIdx line = do v <- tempVec `M.read` readIdx let v0 = (v `unsafeShiftR` 6) .&. 0x3 v1 = (v `unsafeShiftR` 4) .&. 0x3 v2 = (v `unsafeShiftR` 2) .&. 0x3 v3 = v .&. 0x3 (outVec `M.write` writeIdx) v0 when (writeIdx + 1 * stride < maxWrite) $ (outVec `M.write` (writeIdx + stride)) v1 when (writeIdx + 2 * stride < maxWrite) $ (outVec `M.write` (writeIdx + stride * 2)) v2 when (writeIdx + 3 * stride < maxWrite) $ (outVec `M.write` (writeIdx + stride * 3)) v3 inner (readIdx + 1) (writeIdx + 4 * stride) (line - 4) data Pack12 = Pack12 instance Unpackable Pack12 where type StorageType Pack12 = Word16 allocTempBuffer _ _ = M.new offsetStride _ _ _ = (0, 1) outAlloc _ = M.new mergeBackTempBuffer _ _ tempVec lineSize index size stride outVec = inner 0 index pxCount where pxCount = lineSize `div` stride maxWrite = M.length outVec inner readIdx writeIdx _ | readIdx >= fromIntegral size || writeIdx >= maxWrite = pure () inner readIdx writeIdx line | line <= 0 = inner readIdx (writeIdx + line * stride) pxCount inner readIdx writeIdx line = do v0 <- tempVec `M.read` readIdx v1 <- if readIdx + 1 < fromIntegral size then tempVec `M.read` (readIdx + 1) else pure 0 v2 <- if readIdx + 2 < fromIntegral size then tempVec `M.read` (readIdx + 2) else pure 0 let high0 = fromIntegral v0 `unsafeShiftL` 4 low0 = (fromIntegral v1 `unsafeShiftR` 4) .&. 0xF p0 = high0 .|. low0 high1 = (fromIntegral v1 .&. 0xF) `unsafeShiftL` 8 low1 = fromIntegral v2 p1 = high1 .|. low1 (outVec `M.write` writeIdx) p0 when (writeIdx + 1 * stride < maxWrite) $ (outVec `M.write` (writeIdx + stride)) p1 inner (readIdx + 3) (writeIdx + 2 * stride) (line - 2) data YCbCrSubsampling = YCbCrSubsampling { ycbcrWidth :: !Int , ycbcrHeight :: !Int , ycbcrImageWidth :: !Int , ycbcrStripHeight :: !Int } instance Unpackable YCbCrSubsampling where type StorageType YCbCrSubsampling = Word8 offsetStride _ _ _ = (0, 1) outAlloc _ = M.new allocTempBuffer _ _ = M.new mergeBackTempBuffer subSampling _ tempVec _ index size _ outVec = foldM_ unpacker 0 [(bx, by) | by <- [0, h .. lineCount - 1] , bx <- [0, w .. imgWidth - 1]] where w = ycbcrWidth subSampling h = ycbcrHeight subSampling imgWidth = ycbcrImageWidth subSampling lineCount = ycbcrStripHeight subSampling lumaCount = w * h blockSize = lumaCount + 2 maxOut = M.length outVec unpacker readIdx _ | readIdx >= fromIntegral size * 3 = pure readIdx unpacker readIdx (bx, by) = do cb <- tempVec `M.read` (readIdx + lumaCount) cr <- tempVec `M.read` (readIdx + lumaCount + 1) let pixelIndices = [index + ((by + y) * imgWidth + bx + x) * 3 | y <- [0 .. h - 1], x <- [0 .. w - 1]] writer readIndex writeIdx | writeIdx + 3 > maxOut = pure readIndex writer readIndex writeIdx = do y <- tempVec `M.read` readIndex (outVec `M.write` writeIdx) y (outVec `M.write` (writeIdx + 1)) cb (outVec `M.write` (writeIdx + 2)) cr return $ readIndex + 1 foldM_ writer readIdx pixelIndices return $ readIdx + blockSize gatherStrips :: ( Unpackable comp , Pixel pixel , StorageType comp ~ PixelBaseComponent pixel ) => comp -> B.ByteString -> TiffInfo -> Image pixel gatherStrips comp str nfo = runST $ do let width = fromIntegral $ tiffWidth nfo height = fromIntegral $ tiffHeight nfo sampleCount = if tiffSampleCount nfo /= 0 then fromIntegral $ tiffSampleCount nfo else V.length $ tiffBitsPerSample nfo rowPerStrip = fromIntegral $ tiffRowPerStrip nfo endianness = hdrEndianness $ tiffHeader nfo stripCount = V.length $ tiffOffsets nfo compression = tiffCompression nfo outVec <- outAlloc comp $ width * height * sampleCount tempVec <- allocTempBuffer comp outVec (rowPerStrip * width * sampleCount) let mutableImage = MutableImage { mutableImageWidth = fromIntegral width , mutableImageHeight = fromIntegral height , mutableImageData = outVec } case tiffPlaneConfiguration nfo of PlanarConfigContig -> V.mapM_ unpacker sizes where unpacker (idx, stripSampleCount, offset, packedSize) = do let (writeIdx, tempStride) = offsetStride comp idx 1 _ <- uncompressAt compression str tempVec tempStride writeIdx (offset, packedSize) let typ :: M.MVector s a -> a typ = const undefined sampleSize = sizeOf (typ outVec) mergeBackTempBuffer comp endianness tempVec (width * sampleCount) idx (fromIntegral $ stripSampleCount * sampleSize) 1 outVec 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 _ <- uncompressAt compression str tempVec tempStride writeIdx (offset, size) mergeBackTempBuffer comp endianness tempVec (width * sampleCount) idx size stride outVec stride = V.length $ tiffOffsets nfo idxVector = V.enumFromN 0 stride sizes = V.zip3 idxVector (tiffOffsets nfo) (tiffStripSize nfo) when (tiffPredictor nfo == PredictorHorizontalDifferencing) $ do let f _ c1 c2 = c1 + c2 forM_ [0 .. height - 1] $ \y -> forM_ [1 .. width - 1] $ \x -> do p <- readPixel mutableImage (x - 1) y q <- readPixel mutableImage x y writePixel mutableImage x y $ mixWith f p q unsafeFreezeImage mutableImage ifdSingleLong :: ExifTag -> Word32 -> Writer [ImageFileDirectory] () ifdSingleLong tag = ifdMultiLong tag . V.singleton ifdSingleShort :: Endianness -> ExifTag -> Word16 -> Writer [ImageFileDirectory] () ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral ifdMultiLong :: ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () ifdMultiLong tag v = tell . pure $ ImageFileDirectory { ifdIdentifier = tag , ifdType = TypeLong , ifdCount = fromIntegral $ V.length v , ifdOffset = offset , ifdExtended = extended } where (offset, extended) | V.length v > 1 = (0, ExifLongs v) | otherwise = (V.head v, ExifNone) ifdMultiShort :: Endianness -> ExifTag -> V.Vector Word32 -> Writer [ImageFileDirectory] () ifdMultiShort endian tag v = tell . pure $ ImageFileDirectory { ifdIdentifier = tag , ifdType = TypeShort , ifdCount = size , ifdOffset = offset , ifdExtended = extended } where size = fromIntegral $ V.length v (offset, extended) | size > 2 = (0, ExifShorts $ V.map fromIntegral v) | size == 2 = let v1 = fromIntegral $ V.head v v2 = fromIntegral $ v `V.unsafeIndex` 1 in case endian of EndianLittle -> (v2 `unsafeShiftL` 16 .|. v1, ExifNone) EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExifNone) | otherwise = case endian of EndianLittle -> (V.head v, ExifNone) EndianBig -> (V.head v `unsafeShiftL` 16, ExifNone) instance BinaryParam B.ByteString TiffInfo where putP rawData nfo = putP rawData (tiffHeader nfo, list) where endianness = hdrEndianness $ tiffHeader nfo ifdShort = ifdSingleShort endianness ifdShorts = ifdMultiShort endianness list = execWriter $ do ifdSingleLong TagImageWidth $ tiffWidth nfo ifdSingleLong TagImageLength $ tiffHeight nfo ifdShorts TagBitsPerSample $ tiffBitsPerSample nfo ifdSingleLong TagSamplesPerPixel $ tiffSampleCount nfo ifdSingleLong TagRowPerStrip $ tiffRowPerStrip nfo ifdShort TagPhotometricInterpretation . packPhotometricInterpretation $ tiffColorspace nfo ifdShort TagPlanarConfiguration . constantToPlaneConfiguration $ tiffPlaneConfiguration nfo ifdShort TagCompression . packCompression $ tiffCompression nfo ifdMultiLong TagStripOffsets $ tiffOffsets nfo ifdMultiLong TagStripByteCounts $ tiffStripSize nfo maybe (return ()) (ifdShort TagExtraSample . codeOfExtraSample) $ tiffExtraSample nfo let subSampling = tiffYCbCrSubsampling nfo unless (V.null subSampling) $ ifdShorts TagYCbCrSubsampling subSampling getP rawData = do (hdr, cleaned) <- getP rawData let dataFind str tag = findIFDData str tag cleaned dataDefault def tag = findIFDDefaultData def tag cleaned extFind str tag = findIFDExt str tag cleaned extDefault def tag = findIFDExtDefaultData def tag cleaned TiffInfo hdr <$> dataFind "Can't find width" TagImageWidth <*> dataFind "Can't find height" TagImageLength <*> (dataFind "Can't find color space" TagPhotometricInterpretation >>= unpackPhotometricInterpretation) <*> dataFind "Can't find sample per pixel" TagSamplesPerPixel <*> dataFind "Can't find row per strip" TagRowPerStrip <*> (dataDefault 1 TagPlanarConfiguration >>= planarConfgOfConstant) <*> (extDefault [1] TagSampleFormat >>= mapM unpackSampleFormat) <*> (extFind "Can't find bit per sample" TagBitsPerSample >>= unLong "Can't find bit depth") <*> (dataFind "Can't find Compression" TagCompression >>= unPackCompression) <*> (extFind "Can't find byte counts" TagStripByteCounts >>= unLong "Can't find bit per sample") <*> (extFind "Strip offsets missing" TagStripOffsets >>= unLong "Can't find strip offsets") <*> findPalette cleaned <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) <*> pure Nothing <*> (dataDefault 1 TagPredictor >>= predictorOfConstant) <*> pure (extractTiffMetadata cleaned) palette16Of :: Image PixelRGB16 -> Palette' PixelRGB16 palette16Of p = Palette' { _paletteSize = imageWidth p , _paletteData = imageData p } unpack :: B.ByteString -> TiffInfo -> Either String PalettedImage -- | while mandatory some images don't put correct -- rowperstrip. So replacing 0 with actual image height. unpack file nfo@TiffInfo { tiffRowPerStrip = 0 } = unpack file $ nfo { tiffRowPerStrip = tiffHeight nfo } unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted , tiffBitsPerSample = lst , tiffSampleFormat = format , tiffPalette = Just p } | lst == V.singleton 8 && format == [TiffSampleUint] = pure . PalettedRGB16 (gatherStrips (0 :: Word8) file nfo) $ palette16Of p | lst == V.singleton 4 && format == [TiffSampleUint] = pure . PalettedRGB16 (gatherStrips Pack4 file nfo) $ palette16Of p | lst == V.singleton 2 && format == [TiffSampleUint] = pure . PalettedRGB16 (gatherStrips Pack2 file nfo) $ palette16Of p unpack file nfo@TiffInfo { tiffColorspace = TiffCMYK , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageCMYK8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageCMYK16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochromeWhite0 } = do img <- unpack file (nfo { tiffColorspace = TiffMonochrome }) case img of TrueColorImage (ImageY8 i) -> pure . TrueColorImage . ImageY8 $ pixelMap (maxBound -) i TrueColorImage (ImageY16 i) -> pure . TrueColorImage . ImageY16 $ pixelMap (maxBound -) i TrueColorImage (ImageYA8 i) -> let negative (PixelYA8 y a) = PixelYA8 (maxBound - y) a in pure . TrueColorImage . ImageYA8 $ pixelMap negative i TrueColorImage (ImageYA16 i) -> let negative (PixelYA16 y a) = PixelYA16 (maxBound - y) a in pure . TrueColorImage . 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 . TrueColorImage . ImageY8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.singleton 4 && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageY8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.singleton 8 && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageY8 $ gatherStrips (0 :: Word8) file nfo | lst == V.singleton 12 && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageY16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.singleton 16 && all (TiffSampleUint ==) format = pure . TrueColorImage . 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 . TrueColorImage . ImageY16 $ pixelMap toWord16 img | lst == V.fromList [2, 2] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [12, 12] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA16 . pixelMap (colorMap expand12to16) $ gatherStrips Pack12 file nfo | lst == V.fromList [16, 16] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYA16 $ gatherStrips (0 :: Word16) file nfo where expand12to16 x = x `unsafeShiftL` 4 + x `unsafeShiftR` (12 - 4) unpack file nfo@TiffInfo { tiffColorspace = TiffYCbCr , tiffBitsPerSample = lst , tiffPlaneConfiguration = PlanarConfigContig , tiffSampleFormat = format } | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageYCbCr8 $ gatherStrips cbcrConf file nfo where defaulting 0 = 2 defaulting n = n w = defaulting $ tiffYCbCrSubsampling nfo V.! 0 h = defaulting $ tiffYCbCrSubsampling nfo V.! 1 cbcrConf = YCbCrSubsampling { ycbcrWidth = fromIntegral w , ycbcrHeight = fromIntegral h , ycbcrImageWidth = fromIntegral $ tiffWidth nfo , ycbcrStripHeight = fromIntegral $ tiffRowPerStrip nfo } unpack file nfo@TiffInfo { tiffColorspace = TiffRGB , tiffBitsPerSample = lst , tiffSampleFormat = format } | lst == V.fromList [2, 2, 2] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x55 *)) $ gatherStrips Pack2 file nfo | lst == V.fromList [4, 4, 4] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGB8 . pixelMap (colorMap (0x11 *)) $ gatherStrips Pack4 file nfo | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [8, 8, 8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGBA8 $ gatherStrips (0 :: Word8) file nfo | lst == V.fromList [16, 16, 16] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGB16 $ gatherStrips (0 :: Word16) file nfo | lst == V.fromList [16, 16, 16, 16] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGBA16 $ gatherStrips (0 :: Word16) file nfo unpack file nfo@TiffInfo { tiffColorspace = TiffMonochrome , tiffBitsPerSample = lst , tiffSampleFormat = format } -- some files are a little bit borked... | lst == V.fromList [8, 8, 8] && all (TiffSampleUint ==) format = pure . TrueColorImage . ImageRGB8 $ gatherStrips (0 :: Word8) file nfo unpack _ _ = fail "Failure to unpack TIFF file" -- | 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 images: -- -- * 'ImageY8' -- -- * 'ImageY16' -- -- * 'ImageYA8' -- -- * 'ImageYA16' -- -- * 'ImageRGB8' -- -- * 'ImageRGB16' -- -- * 'ImageRGBA8' -- -- * 'ImageRGBA16' -- -- * 'ImageCMYK8' -- -- * 'ImageCMYK16' -- decodeTiff :: B.ByteString -> Either String DynamicImage decodeTiff = fmap fst . decodeTiffWithMetadata -- | Like 'decodeTiff' but also provides some metdata present -- in the Tiff file. -- -- The metadata extracted are the 'Codec.Picture.Metadata.DpiX' & -- 'Codec.Picture.Metadata.DpiY' information alongside the EXIF informations. decodeTiffWithMetadata :: B.ByteString -> Either String (DynamicImage, Metadatas) decodeTiffWithMetadata str = first palettedToTrueColor <$> decodeTiffWithPaletteAndMetadata str -- | Decode TIFF and provide separated palette and metadata decodeTiffWithPaletteAndMetadata :: B.ByteString -> Either String (PalettedImage, Metadatas) decodeTiffWithPaletteAndMetadata file = runGetStrict (getP file) file >>= go where go tinfo = (, tiffMetadatas tinfo) <$> unpack file tinfo -- | Class defining which pixel types can be serialized in a -- Tiff file. class (Pixel px) => TiffSaveable px where colorSpaceOfPixel :: px -> TiffColorspace extraSampleCodeOfPixel :: px -> Maybe ExtraSample extraSampleCodeOfPixel _ = Nothing subSamplingInfo :: px -> V.Vector Word32 subSamplingInfo _ = V.empty instance TiffSaveable Pixel8 where colorSpaceOfPixel _ = TiffMonochrome 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 instance TiffSaveable PixelCMYK16 where colorSpaceOfPixel _ = TiffCMYK instance TiffSaveable PixelRGB8 where colorSpaceOfPixel _ = TiffRGB instance TiffSaveable PixelRGB16 where colorSpaceOfPixel _ = TiffRGB 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, ready to be -- written as a file. encodeTiff :: forall px. (TiffSaveable px) => Image px -> Lb.ByteString encodeTiff img = runPut $ putP rawPixelData hdr where intSampleCount = componentCount (undefined :: px) sampleCount = fromIntegral intSampleCount sampleType = undefined :: PixelBaseComponent px pixelData = imageData img rawPixelData = toByteString pixelData width = fromIntegral $ imageWidth img height = fromIntegral $ imageHeight img intSampleSize = sizeOf sampleType sampleSize = fromIntegral intSampleSize bitPerSample = sampleSize * 8 imageSize = width * height * sampleCount * sampleSize headerSize = 8 hdr = TiffInfo { tiffHeader = TiffHeader { hdrEndianness = EndianLittle , hdrOffset = headerSize + imageSize } , tiffWidth = width , tiffHeight = height , tiffColorspace = colorSpaceOfPixel (undefined :: px) , tiffSampleCount = fromIntegral sampleCount , tiffRowPerStrip = fromIntegral $ imageHeight img , tiffPlaneConfiguration = PlanarConfigContig , tiffSampleFormat = [TiffSampleUint] , tiffBitsPerSample = V.replicate intSampleCount bitPerSample , tiffCompression = CompressionNone , tiffStripSize = V.singleton imageSize , tiffOffsets = V.singleton headerSize , tiffPalette = Nothing , tiffYCbCrSubsampling = subSamplingInfo (undefined :: px) , tiffExtraSample = extraSampleCodeOfPixel (undefined :: px) , tiffPredictor = PredictorNone -- not used when writing , tiffMetadatas = mempty } -- | Helper function to directly write an image as a tiff on disk. writeTiff :: (TiffSaveable pixel) => FilePath -> Image pixel -> IO () writeTiff path img = Lb.writeFile path $ encodeTiff img {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/Metadata.hs0000644000000000000000000001754212763010461017466 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} -- | This module expose a common "metadata" storage for various image -- type. Different format can generate different metadatas, and write -- only a part of them. -- -- Since version 3.2.5 -- module Codec.Picture.Metadata( -- * Types Metadatas , Keys( .. ) , Value( .. ) , Elem( .. ) , SourceFormat( .. ) -- * Functions , Codec.Picture.Metadata.lookup , empty , insert , delete , singleton -- * Folding , foldl' , Codec.Picture.Metadata.foldMap -- * Helper functions , mkDpiMetadata , mkSizeMetadata , basicMetadata , simpleMetadata -- * Conversion functions , dotsPerMeterToDotPerInch , dotPerInchToDotsPerMeter , dotsPerCentiMeterToDotPerInch ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( Monoid, mempty, mappend ) import Data.Word( Word ) #endif import Control.DeepSeq( NFData( .. ) ) import qualified Data.Foldable as F import Codec.Picture.Metadata.Exif #if MIN_VERSION_base(4,7,0) import Data.Typeable( (:~:)( Refl ) ) type Equiv = (:~:) #else data Equiv a b where Refl :: Equiv a a #endif -- | Type describing the original file format of the ilfe. data SourceFormat = SourceJpeg | SourceGif | SourceBitmap | SourceTiff | SourcePng | SourceHDR | SourceTGA deriving (Eq, Show) instance NFData SourceFormat where rnf a = a `seq` () -- | Store various additional information about an image. If -- something is not recognized, it can be stored in an unknown tag. -- -- * 'DpiX' Dot per inch on this x axis. -- -- * 'DpiY' Dot per inch on this y axis. -- -- * 'Width' Image width in pixel. Relying on the metadata for this -- information can avoid the full decompression of the image. -- Ignored for image writing. -- -- * 'Height' Image height in pixels. Relyiung on the metadata for this -- information can void the full decomrpession of the image. -- Ignored for image writing. -- -- * 'Unknown' unlikely to be decoded, but usefull for metadata writing -- -- * 'Exif' Exif tag and associated data. -- data Keys a where Gamma :: Keys Double Format :: Keys SourceFormat DpiX :: Keys Word DpiY :: Keys Word Width :: Keys Word Height :: Keys Word Title :: Keys String Description :: Keys String Author :: Keys String Copyright :: Keys String Software :: Keys String Comment :: Keys String Disclaimer :: Keys String Source :: Keys String Warning :: Keys String Exif :: !ExifTag -> Keys ExifData Unknown :: !String -> Keys Value deriving instance Show (Keys a) deriving instance Eq (Keys a) {-deriving instance Ord (Keys a)-} -- | Encode values for unknown information data Value = Int !Int | Double !Double | String !String deriving (Eq, Show) instance NFData Value where rnf v = v `seq` () -- everything is strict, so it's OK -- | Element describing a metadata and it's (typed) associated -- value. data Elem k = forall a. (Show a, NFData a) => !(k a) :=> a deriving instance Show (Elem Keys) instance NFData (Elem Keys) where rnf (_ :=> v) = rnf v `seq` () keyEq :: Keys a -> Keys b -> Maybe (Equiv a b) keyEq a b = case (a, b) of (Gamma, Gamma) -> Just Refl (DpiX, DpiX) -> Just Refl (DpiY, DpiY) -> Just Refl (Width, Width) -> Just Refl (Height, Height) -> Just Refl (Title, Title) -> Just Refl (Description, Description) -> Just Refl (Author, Author) -> Just Refl (Copyright, Copyright) -> Just Refl (Software, Software) -> Just Refl (Comment, Comment) -> Just Refl (Disclaimer, Disclaimer) -> Just Refl (Source, Source) -> Just Refl (Warning, Warning) -> Just Refl (Format, Format) -> Just Refl (Unknown v1, Unknown v2) | v1 == v2 -> Just Refl (Exif t1, Exif t2) | t1 == t2 -> Just Refl _ -> Nothing -- | Dependent storage used for metadatas. -- All metadatas of a given kind are unique within -- this container. -- -- The current data structure is based on list, -- so bad performances can be expected. newtype Metadatas = Metadatas { getMetadatas :: [Elem Keys] } deriving (Show, NFData) instance Monoid Metadatas where mempty = empty mappend = union -- | Right based union union :: Metadatas -> Metadatas -> Metadatas union m1 = F.foldl' go m1 . getMetadatas where go acc el@(k :=> _) = Metadatas $ el : getMetadatas (delete k acc) -- | Strict left fold of the metadatas foldl' :: (acc -> Elem Keys -> acc) -> acc -> Metadatas -> acc foldl' f initAcc = F.foldl' f initAcc . getMetadatas -- | foldMap equivalent for metadatas. foldMap :: Monoid m => (Elem Keys -> m) -> Metadatas -> m foldMap f = foldl' (\acc v -> acc `mappend` f v) mempty -- | Remove an element of the given keys from the metadatas. -- If not present does nothing. delete :: Keys a -> Metadatas -> Metadatas delete k = Metadatas . go . getMetadatas where go [] = [] go (el@(k2 :=> _) : rest) = case keyEq k k2 of Nothing -> el : go rest Just Refl -> rest -- | Search a metadata with the given key. lookup :: Keys a -> Metadatas -> Maybe a lookup k = go . getMetadatas where go [] = Nothing go ((k2 :=> v) : rest) = case keyEq k k2 of Nothing -> go rest Just Refl -> Just v -- | Insert an element in the metadatas, if an element with -- the same key is present, it is overwritten. insert :: (Show a, NFData a) => Keys a -> a -> Metadatas -> Metadatas insert k val metas = Metadatas $ (k :=> val) : getMetadatas (delete k metas) -- | Create metadatas with a single element. singleton :: (Show a, NFData a) => Keys a -> a -> Metadatas singleton k val = Metadatas [k :=> val] -- | Empty metadatas. Favor 'mempty' empty :: Metadatas empty = Metadatas mempty -- | Conversion from dpm to dpi dotsPerMeterToDotPerInch :: Word -> Word dotsPerMeterToDotPerInch z = z * 254 `div` 10000 -- | Conversion from dpi to dpm dotPerInchToDotsPerMeter :: Word -> Word dotPerInchToDotsPerMeter z = (z * 10000) `div` 254 -- | Conversion dpcm -> dpi dotsPerCentiMeterToDotPerInch :: Word -> Word dotsPerCentiMeterToDotPerInch z = z * 254 `div` 100 -- | Create metadatas indicating the resolution, with DpiX == DpiY mkDpiMetadata :: Word -> Metadatas mkDpiMetadata w = Metadatas [DpiY :=> w, DpiX :=> w] -- | Create metadatas holding width and height information. mkSizeMetadata :: Integral n => n -> n -> Metadatas mkSizeMetadata w h = Metadatas [ Width :=> fromIntegral w, Height :=> fromIntegral h ] -- | Create simple metadatas with Format, Width & Height basicMetadata :: Integral nSize => SourceFormat -> nSize -> nSize -> Metadatas basicMetadata f w h = Metadatas [ Format :=> f , Width :=> fromIntegral w , Height :=> fromIntegral h ] -- | Create simple metadatas with Format, Width, Height, DpiX & DpiY simpleMetadata :: (Integral nSize, Integral nDpi) => SourceFormat -> nSize -> nSize -> nDpi -> nDpi -> Metadatas simpleMetadata f w h dpiX dpiY = Metadatas [ Format :=> f , Width :=> fromIntegral w , Height :=> fromIntegral h , DpiX :=> fromIntegral dpiX , DpiY :=> fromIntegral dpiY ] JuicyPixels-3.2.8/src/Codec/Picture/Metadata/Exif.hs0000644000000000000000000001240312763010461020350 0ustar0000000000000000-- | This module provide a totally partial and incomplete maping -- of Exif values. Used for Tiff parsing and reused for Exif extraction. module Codec.Picture.Metadata.Exif ( ExifTag( .. ) , ExifData( .. ) , tagOfWord16 , word16OfTag ) where import Control.DeepSeq( NFData( .. ) ) import Data.Int( Int32 ) import Data.Word( Word16, Word32 ) import qualified Data.Vector as V import qualified Data.ByteString as B -- | Tag values used for exif fields. Completly incomplete data ExifTag = TagPhotometricInterpretation | TagCompression -- ^ Short type | TagImageWidth -- ^ Short or long type | TagImageLength -- ^ Short or long type | TagXResolution -- ^ Rational type | TagYResolution -- ^ Rational type | TagResolutionUnit -- ^ Short type | TagRowPerStrip -- ^ Short or long type | TagStripByteCounts -- ^ Short or long | TagStripOffsets -- ^ Short or long | TagBitsPerSample -- ^ Short | TagColorMap -- ^ Short | TagTileWidth | TagTileLength | TagTileOffset | TagTileByteCount | TagSamplesPerPixel -- ^ Short | TagArtist | TagDocumentName | TagSoftware | TagPlanarConfiguration -- ^ Short | TagOrientation | TagSampleFormat -- ^ Short | TagInkSet | TagSubfileType | TagFillOrder | TagYCbCrCoeff | TagYCbCrSubsampling | TagYCbCrPositioning | TagReferenceBlackWhite | TagXPosition | TagYPosition | TagExtraSample | TagImageDescription | TagPredictor | TagCopyright | TagMake | TagModel | TagDateTime | TagGPSInfo | TagJpegProc | TagJPEGInterchangeFormat | TagJPEGInterchangeFormatLength | TagJPEGRestartInterval | TagJPEGLosslessPredictors | TagJPEGPointTransforms | TagJPEGQTables | TagJPEGDCTables | TagJPEGACTables | TagExifOffset | TagUnknown !Word16 deriving (Eq, Ord, Show) -- | Convert a value to it's corresponding Exif tag. -- Will often be written as 'TagUnknown' tagOfWord16 :: Word16 -> ExifTag tagOfWord16 v = case v of 255 -> TagSubfileType 256 -> TagImageWidth 257 -> TagImageLength 258 -> TagBitsPerSample 259 -> TagCompression 262 -> TagPhotometricInterpretation 266 -> TagFillOrder 269 -> TagDocumentName 270 -> TagImageDescription 271 -> TagMake 272 -> TagModel 273 -> TagStripOffsets 274 -> TagOrientation 277 -> TagSamplesPerPixel 278 -> TagRowPerStrip 279 -> TagStripByteCounts 282 -> TagXResolution 283 -> TagYResolution 284 -> TagPlanarConfiguration 286 -> TagXPosition 287 -> TagYPosition 296 -> TagResolutionUnit 305 -> TagSoftware 306 -> TagDateTime 315 -> TagArtist 317 -> TagPredictor 320 -> TagColorMap 322 -> TagTileWidth 323 -> TagTileLength 324 -> TagTileOffset 325 -> TagTileByteCount 332 -> TagInkSet 338 -> TagExtraSample 339 -> TagSampleFormat 529 -> TagYCbCrCoeff 512 -> TagJpegProc 513 -> TagJPEGInterchangeFormat 514 -> TagJPEGInterchangeFormatLength 515 -> TagJPEGRestartInterval 517 -> TagJPEGLosslessPredictors 518 -> TagJPEGPointTransforms 519 -> TagJPEGQTables 520 -> TagJPEGDCTables 521 -> TagJPEGACTables 530 -> TagYCbCrSubsampling 531 -> TagYCbCrPositioning 532 -> TagReferenceBlackWhite 33432 -> TagCopyright 34665 -> TagExifOffset 34853 -> TagGPSInfo vv -> TagUnknown vv -- | Convert a tag to it's corresponding value. word16OfTag :: ExifTag -> Word16 word16OfTag t = case t of TagSubfileType -> 255 TagImageWidth -> 256 TagImageLength -> 257 TagBitsPerSample -> 258 TagCompression -> 259 TagPhotometricInterpretation -> 262 TagFillOrder -> 266 TagDocumentName -> 269 TagImageDescription -> 270 TagMake -> 271 TagModel -> 272 TagStripOffsets -> 273 TagOrientation -> 274 TagSamplesPerPixel -> 277 TagRowPerStrip -> 278 TagStripByteCounts -> 279 TagXResolution -> 282 TagYResolution -> 283 TagPlanarConfiguration -> 284 TagXPosition -> 286 TagYPosition -> 287 TagResolutionUnit -> 296 TagSoftware -> 305 TagDateTime -> 306 TagArtist -> 315 TagPredictor -> 317 TagColorMap -> 320 TagTileWidth -> 322 TagTileLength -> 323 TagTileOffset -> 324 TagTileByteCount -> 325 TagInkSet -> 332 TagExtraSample -> 338 TagSampleFormat -> 339 TagYCbCrCoeff -> 529 TagJpegProc -> 512 TagJPEGInterchangeFormat -> 513 TagJPEGInterchangeFormatLength -> 514 TagJPEGRestartInterval -> 515 TagJPEGLosslessPredictors -> 517 TagJPEGPointTransforms -> 518 TagJPEGQTables -> 519 TagJPEGDCTables -> 520 TagJPEGACTables -> 521 TagYCbCrSubsampling -> 530 TagYCbCrPositioning -> 531 TagReferenceBlackWhite -> 532 TagCopyright -> 33432 TagExifOffset -> 34665 TagGPSInfo -> 34853 (TagUnknown v) -> v -- | Possible data held by an Exif tag data ExifData = ExifNone | ExifLong !Word32 | ExifShort !Word16 | ExifString !B.ByteString | ExifUndefined !B.ByteString | ExifShorts !(V.Vector Word16) | ExifLongs !(V.Vector Word32) | ExifRational !Word32 !Word32 | ExifSignedRational !Int32 !Int32 | ExifIFD ![(ExifTag, ExifData)] deriving Show instance NFData ExifTag where rnf a = a `seq` () instance NFData ExifData where rnf (ExifIFD ifds) = rnf ifds `seq` () rnf (ExifLongs l) = rnf l `seq` () rnf (ExifShorts l) = rnf l `seq` () rnf a = a `seq` () JuicyPixels-3.2.8/src/Codec/Picture/Saving.hs0000644000000000000000000002454412763010461017175 0ustar0000000000000000{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} -- | Helper functions to save dynamic images to other file format -- with automatic color space/sample format conversion done automatically. module Codec.Picture.Saving( imageToJpg , imageToPng , imageToGif , imageToBitmap , imageToTiff , imageToRadiance , imageToTga ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) #endif import Data.Bits( unsafeShiftR ) import Data.Word( Word8, Word16 ) import qualified Data.ByteString.Lazy as L import Codec.Picture.Bitmap import Codec.Picture.Jpg import Codec.Picture.Png import Codec.Picture.Gif import Codec.Picture.ColorQuant import Codec.Picture.HDR import Codec.Picture.Types import Codec.Picture.Tiff import Codec.Picture.Tga import qualified Data.Vector.Storable as V componentToLDR :: Float -> Word8 componentToLDR = truncate . (255 *) . min 1.0 . max 0.0 toStandardDef :: Image PixelRGBF -> Image PixelRGB8 toStandardDef = pixelMap pixelConverter where pixelConverter (PixelRGBF rf gf bf) = PixelRGB8 r g b where r = componentToLDR rf g = componentToLDR gf b = componentToLDR bf greyScaleToStandardDef :: Image PixelF -> Image Pixel8 greyScaleToStandardDef = pixelMap componentToLDR from16to8 :: ( PixelBaseComponent source ~ Word16 , PixelBaseComponent dest ~ Word8 ) => Image source -> Image dest from16to8 Image { imageWidth = w, imageHeight = h , imageData = arr } = Image w h transformed where transformed = V.map toWord8 arr toWord8 v = fromIntegral (v `unsafeShiftR` 8) from16toFloat :: ( PixelBaseComponent source ~ Word16 , PixelBaseComponent dest ~ Float ) => Image source -> Image dest from16toFloat Image { imageWidth = w, imageHeight = h , imageData = arr } = Image w h transformed where transformed = V.map toWord8 arr toWord8 v = fromIntegral v / 65536.0 -- | This function will try to do anything to encode an image -- as RADIANCE, make all color conversion and such. Equivalent -- of 'decodeImage' for radiance encoding imageToRadiance :: DynamicImage -> L.ByteString imageToRadiance (ImageCMYK8 img) = imageToRadiance . ImageRGB8 $ convertImage img imageToRadiance (ImageCMYK16 img) = imageToRadiance . ImageRGB16 $ convertImage img imageToRadiance (ImageYCbCr8 img) = imageToRadiance . ImageRGB8 $ convertImage img imageToRadiance (ImageRGB8 img) = imageToRadiance . ImageRGBF $ promoteImage img imageToRadiance (ImageRGBF img) = encodeHDR img imageToRadiance (ImageRGBA8 img) = imageToRadiance . ImageRGBF . promoteImage $ dropAlphaLayer img imageToRadiance (ImageY8 img) = imageToRadiance . ImageRGB8 $ promoteImage img imageToRadiance (ImageYF img) = imageToRadiance . ImageRGBF $ promoteImage img imageToRadiance (ImageYA8 img) = imageToRadiance . ImageRGB8 . promoteImage $ dropAlphaLayer img imageToRadiance (ImageY16 img) = imageToRadiance . ImageRGBF $ pixelMap toRgbf img where toRgbf v = PixelRGBF val val val where val = fromIntegral v / 65536.0 imageToRadiance (ImageYA16 img) = imageToRadiance . ImageRGBF $ pixelMap toRgbf img where toRgbf (PixelYA16 v _) = PixelRGBF val val val where val = fromIntegral v / 65536.0 imageToRadiance (ImageRGB16 img) = imageToRadiance . ImageRGBF $ from16toFloat img imageToRadiance (ImageRGBA16 img) = imageToRadiance . ImageRGBF $ pixelMap toRgbf img where toRgbf (PixelRGBA16 r g b _) = PixelRGBF (f r) (f g) (f b) where f v = fromIntegral v / 65536.0 -- | This function will try to do anything to encode an image -- as JPEG, make all color conversion and such. Equivalent -- of 'decodeImage' for jpeg encoding -- Save Y or YCbCr Jpeg only, all other colorspaces are converted. -- To save a RGB or CMYK JPEG file, use the -- 'Codec.Picture.Jpg.encodeDirectJpegAtQualityWithMetadata' function imageToJpg :: Int -> DynamicImage -> L.ByteString imageToJpg quality dynImage = let encodeAtQuality = encodeJpegAtQuality (fromIntegral quality) encodeWithMeta = encodeDirectJpegAtQualityWithMetadata (fromIntegral quality) mempty in case dynImage of ImageYCbCr8 img -> encodeAtQuality img ImageCMYK8 img -> imageToJpg quality . ImageRGB8 $ convertImage img ImageCMYK16 img -> imageToJpg quality . ImageRGB16 $ convertImage img ImageRGB8 img -> encodeAtQuality (convertImage img) ImageRGBF img -> imageToJpg quality . ImageRGB8 $ toStandardDef img ImageRGBA8 img -> encodeAtQuality (convertImage $ dropAlphaLayer img) ImageYF img -> imageToJpg quality . ImageY8 $ greyScaleToStandardDef img ImageY8 img -> encodeWithMeta img ImageYA8 img -> encodeWithMeta $ dropAlphaLayer img ImageY16 img -> imageToJpg quality . ImageY8 $ from16to8 img ImageYA16 img -> imageToJpg quality . ImageYA8 $ from16to8 img ImageRGB16 img -> imageToJpg quality . ImageRGB8 $ from16to8 img ImageRGBA16 img -> imageToJpg quality . ImageRGBA8 $ from16to8 img -- | This function will try to do anything to encode an image -- as PNG, make all color conversion and such. Equivalent -- of 'decodeImage' for PNG encoding imageToPng :: DynamicImage -> L.ByteString imageToPng (ImageYCbCr8 img) = encodePng (convertImage img :: Image PixelRGB8) imageToPng (ImageCMYK8 img) = encodePng (convertImage img :: Image PixelRGB8) imageToPng (ImageCMYK16 img) = encodePng (convertImage img :: Image PixelRGB16) imageToPng (ImageRGB8 img) = encodePng img imageToPng (ImageRGBF img) = encodePng $ toStandardDef img imageToPng (ImageRGBA8 img) = encodePng img imageToPng (ImageY8 img) = encodePng img imageToPng (ImageYF img) = encodePng $ greyScaleToStandardDef img imageToPng (ImageYA8 img) = encodePng img imageToPng (ImageY16 img) = encodePng img imageToPng (ImageYA16 img) = encodePng img imageToPng (ImageRGB16 img) = encodePng img imageToPng (ImageRGBA16 img) = encodePng img -- | This function will try to do anything to encode an image -- as a Tiff, make all color conversion and such. Equivalent -- of 'decodeImage' for Tiff encoding imageToTiff :: DynamicImage -> L.ByteString imageToTiff (ImageYCbCr8 img) = encodeTiff img imageToTiff (ImageCMYK8 img) = encodeTiff img imageToTiff (ImageCMYK16 img) = encodeTiff img imageToTiff (ImageRGB8 img) = encodeTiff img imageToTiff (ImageRGBF img) = encodeTiff $ toStandardDef img imageToTiff (ImageRGBA8 img) = encodeTiff img imageToTiff (ImageY8 img) = encodeTiff img imageToTiff (ImageYF img) = encodeTiff $ greyScaleToStandardDef img imageToTiff (ImageYA8 img) = encodeTiff $ dropAlphaLayer img imageToTiff (ImageY16 img) = encodeTiff img imageToTiff (ImageYA16 img) = encodeTiff $ dropAlphaLayer img imageToTiff (ImageRGB16 img) = encodeTiff img imageToTiff (ImageRGBA16 img) = encodeTiff img -- | This function will try to do anything to encode an image -- as bitmap, make all color conversion and such. Equivalent -- of 'decodeImage' for Bitmap encoding imageToBitmap :: DynamicImage -> L.ByteString imageToBitmap (ImageYCbCr8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) imageToBitmap (ImageCMYK8 img) = encodeBitmap (convertImage img :: Image PixelRGB8) imageToBitmap (ImageCMYK16 img) = imageToBitmap . ImageRGB16 $ convertImage img imageToBitmap (ImageRGBF img) = encodeBitmap $ toStandardDef img imageToBitmap (ImageRGB8 img) = encodeBitmap img imageToBitmap (ImageRGBA8 img) = encodeBitmap img imageToBitmap (ImageY8 img) = encodeBitmap img imageToBitmap (ImageYF img) = encodeBitmap $ greyScaleToStandardDef img imageToBitmap (ImageYA8 img) = encodeBitmap (promoteImage img :: Image PixelRGBA8) imageToBitmap (ImageY16 img) = imageToBitmap . ImageY8 $ from16to8 img imageToBitmap (ImageYA16 img) = imageToBitmap . ImageYA8 $ from16to8 img imageToBitmap (ImageRGB16 img) = imageToBitmap . ImageRGB8 $ from16to8 img imageToBitmap (ImageRGBA16 img) = imageToBitmap . ImageRGBA8 $ from16to8 img -- | This function will try to do anything to encode an image -- as a gif, make all color conversion and quantization. Equivalent -- of 'decodeImage' for gif encoding imageToGif :: DynamicImage -> Either String L.ByteString imageToGif (ImageYCbCr8 img) = imageToGif . ImageRGB8 $ convertImage img imageToGif (ImageCMYK8 img) = imageToGif . ImageRGB8 $ convertImage img imageToGif (ImageCMYK16 img) = imageToGif . ImageRGB16 $ convertImage img imageToGif (ImageRGBF img) = imageToGif . ImageRGB8 $ toStandardDef img imageToGif (ImageRGB8 img) = encodeGifImageWithPalette indexed pal where (indexed, pal) = palettize defaultPaletteOptions img imageToGif (ImageRGBA8 img) = imageToGif . ImageRGB8 $ dropAlphaLayer img imageToGif (ImageY8 img) = Right $ encodeGifImage img imageToGif (ImageYF img) = imageToGif . ImageY8 $ greyScaleToStandardDef img imageToGif (ImageYA8 img) = imageToGif . ImageY8 $ dropAlphaLayer img imageToGif (ImageY16 img) = imageToGif . ImageY8 $ from16to8 img imageToGif (ImageYA16 img) = imageToGif . ImageYA8 $ from16to8 img imageToGif (ImageRGB16 img) = imageToGif . ImageRGB8 $ from16to8 img imageToGif (ImageRGBA16 img) = imageToGif . ImageRGBA8 $ from16to8 img -- | This function will try to do anything to encode an image -- as a tga, make all color conversion and quantization. Equivalent -- of 'decodeImage' for tga encoding imageToTga :: DynamicImage -> L.ByteString imageToTga (ImageYCbCr8 img) = encodeTga (convertImage img :: Image PixelRGB8) imageToTga (ImageCMYK8 img) = encodeTga (convertImage img :: Image PixelRGB8) imageToTga (ImageCMYK16 img) = encodeTga (from16to8 img :: Image PixelRGB8) imageToTga (ImageRGBF img) = encodeTga $ toStandardDef img imageToTga (ImageRGB8 img) = encodeTga img imageToTga (ImageRGBA8 img) = encodeTga img imageToTga (ImageY8 img) = encodeTga img imageToTga (ImageYF img) = encodeTga $ greyScaleToStandardDef img imageToTga (ImageYA8 img) = encodeTga (promoteImage img :: Image PixelRGBA8) imageToTga (ImageY16 img) = encodeTga (from16to8 img :: Image Pixel8) imageToTga (ImageYA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) imageToTga (ImageRGB16 img) = encodeTga (from16to8 img :: Image PixelRGB8) imageToTga (ImageRGBA16 img) = encodeTga (from16to8 img :: Image PixelRGBA8) JuicyPixels-3.2.8/src/Codec/Picture/Types.hs0000644000000000000000000031010012763046173017045 0ustar0000000000000000{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -- | Module provides basic types for image manipulation in the library. -- Defined types are used to store all of those __Juicy Pixels__ module Codec.Picture.Types( -- * Types -- ** Image types Image( .. ) , MutableImage( .. ) , DynamicImage( .. ) , PalettedImage( .. ) , Palette , Palette'( .. ) -- ** Image functions , createMutableImage , newMutableImage , freezeImage , unsafeFreezeImage , thawImage , unsafeThawImage -- ** Image Lenses , Traversal , imagePixels , imageIPixels -- ** Pixel types , Pixel8 , Pixel16 , Pixel32 , PixelF , PixelYA8( .. ) , PixelYA16( .. ) , PixelRGB8( .. ) , PixelRGB16( .. ) , PixelRGBF( .. ) , PixelRGBA8( .. ) , PixelRGBA16( .. ) , PixelCMYK8( .. ) , PixelCMYK16( .. ) , PixelYCbCr8( .. ) , PixelYCbCrK8( .. ) -- * Type classes , ColorConvertible( .. ) , Pixel(..) -- $graph , ColorSpaceConvertible( .. ) , LumaPlaneExtractable( .. ) , TransparentPixel( .. ) -- * Helper functions , pixelMap , pixelMapXY , pixelFold , pixelFoldM , pixelFoldMap , dynamicMap , dynamicPixelMap , palettedToTrueColor , palettedAsImage , dropAlphaLayer , withImage , zipPixelComponent3 , generateImage , generateFoldImage , gammaCorrection , toneMapping -- * Color plane extraction , ColorPlane ( ) , PlaneRed( .. ) , PlaneGreen( .. ) , PlaneBlue( .. ) , PlaneAlpha( .. ) , PlaneLuma( .. ) , PlaneCr( .. ) , PlaneCb( .. ) , PlaneCyan( .. ) , PlaneMagenta( .. ) , PlaneYellow( .. ) , PlaneBlack( .. ) , extractComponent , unsafeExtractComponent -- * Packeable writing (unsafe but faster) , PackeablePixel( .. ) , fillImageWith , readPackedPixelAt , writePackedPixelAt , unsafeWritePixelBetweenAt ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( Monoid, mempty ) import Control.Applicative( Applicative, pure, (<*>), (<$>) ) #endif import Data.Monoid( (<>) ) import Control.Monad( foldM, liftM, ap ) import Control.DeepSeq( NFData( .. ) ) import Control.Monad.ST( ST, runST ) import Control.Monad.Primitive ( PrimMonad, PrimState ) import Foreign.ForeignPtr( castForeignPtr ) import Foreign.Storable ( Storable ) import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) ) import Data.Typeable ( Typeable ) import Data.Word( Word8, Word16, Word32, Word64 ) import Data.Vector.Storable ( (!) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M #include "ConvGraph.hs" -- | 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 -- | 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) } deriving (Typeable) -- | Type for the palette used in Gif & PNG files. type Palette = Image PixelRGB8 -- | Class used to describle plane present in the pixel -- type. If a pixel has a plane description associated, -- you can use the plane name to extract planes independently. class ColorPlane pixel planeToken where -- | Retrieve the index of the component in the -- given pixel type. toComponentIndex :: pixel -> planeToken -> Int -- | Define the plane for the red color component data PlaneRed = PlaneRed deriving (Typeable) -- | Define the plane for the green color component data PlaneGreen = PlaneGreen deriving (Typeable) -- | Define the plane for the blue color component data PlaneBlue = PlaneBlue deriving (Typeable) -- | Define the plane for the alpha (transparency) component data PlaneAlpha = PlaneAlpha deriving (Typeable) -- | Define the plane for the luma component data PlaneLuma = PlaneLuma deriving (Typeable) -- | Define the plane for the Cr component data PlaneCr = PlaneCr deriving (Typeable) -- | Define the plane for the Cb component data PlaneCb = PlaneCb deriving (Typeable) -- | Define plane for the cyan component of the -- CMYK color space. data PlaneCyan = PlaneCyan deriving (Typeable) -- | Define plane for the magenta component of the -- CMYK color space. data PlaneMagenta = PlaneMagenta deriving (Typeable) -- | Define plane for the yellow component of the -- CMYK color space. data PlaneYellow = PlaneYellow deriving (Typeable) -- | Define plane for the black component of -- the CMYK color space. data PlaneBlack = PlaneBlack deriving (Typeable) -- | Extract a color plane from an image given a present plane in the image -- examples: -- -- @ -- extractRedPlane :: Image PixelRGB8 -> Image Pixel8 -- extractRedPlane = extractComponent PlaneRed -- @ -- extractComponent :: forall px plane. ( Pixel px , Pixel (PixelBaseComponent px) , PixelBaseComponent (PixelBaseComponent px) ~ PixelBaseComponent px , ColorPlane px plane ) => plane -> Image px -> Image (PixelBaseComponent px) extractComponent plane = unsafeExtractComponent idx where idx = toComponentIndex (undefined :: px) plane -- | 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) , PixelBaseComponent (PixelBaseComponent a) ~ PixelBaseComponent a) => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) -> Image a -- ^ Source image -> Image (PixelBaseComponent a) unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h }) | comp >= padd = error $ "extractComponent : invalid component index (" ++ show comp ++ ", max:" ++ show padd ++ ")" | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } where plane = stride img padd comp padd = componentCount (undefined :: a) -- | For any image with an alpha component (transparency), -- drop it, returning a pure opaque image. dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b dropAlphaLayer = pixelMap dropTransparency -- | Class modeling transparent pixel, should provide a method -- to combine transparent pixels class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where -- | Just return the opaque pixel value dropTransparency :: a -> b -- | access the transparency (alpha layer) of a given -- transparent pixel type. getTransparency :: a -> PixelBaseComponent a {-# DEPRECATED getTransparency "please use 'pixelOpacity' instead" #-} instance TransparentPixel PixelRGBA8 PixelRGB8 where {-# INLINE dropTransparency #-} dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b {-# INLINE getTransparency #-} getTransparency (PixelRGBA8 _ _ _ a) = a 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 -> V.Vector (PixelBaseComponent a) stride Image { imageWidth = w, imageHeight = h, imageData = array } padd firstComponent = runST $ do let cell_count = w * h outArray <- M.new cell_count let go writeIndex _ | writeIndex >= cell_count = return () go writeIndex readIndex = do (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex go (writeIndex + 1) $ readIndex + padd go 0 firstComponent V.unsafeFreeze outArray instance NFData (Image a) where rnf (Image width height dat) = width `seq` height `seq` dat `seq` () -- | 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 image can be transformed in place. data MutableImage s a = MutableImage { -- | Width of the image in pixels mutableImageWidth :: {-# UNPACK #-} !Int -- | Height of the image in pixels. , mutableImageHeight :: {-# UNPACK #-} !Int -- | The real image, to extract pixels at some position -- you should use the helpers functions. , mutableImageData :: M.STVector s (PixelBaseComponent a) } deriving (Typeable) -- | `O(n)` Yield an immutable copy of an image by making a copy of it freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m) => MutableImage (PrimState m) px -> m (Image px) freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d -- | `O(n)` Yield a mutable copy of an image by making a copy of it. thawImage :: (Storable (PixelBaseComponent px), PrimMonad m) => Image px -> m (MutableImage (PrimState m) px) thawImage (Image w h d) = MutableImage w h `liftM` V.thaw d -- | `O(1)` Unsafe convert an imutable image to an mutable one without copying. -- The source image shouldn't be used after this operation. unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m) => Image px -> m (MutableImage (PrimState m) px) {-# NOINLINE unsafeThawImage #-} unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d -- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. -- The mutable image may not be used after this operation. unsafeFreezeImage :: (Storable (PixelBaseComponent a), PrimMonad m) => MutableImage (PrimState m) a -> m (Image a) unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d -- | Create a mutable image, filled with the given background color. createMutableImage :: (Pixel px, PrimMonad m) => Int -- ^ Width -> Int -- ^ Height -> px -- ^ Background color -> m (MutableImage (PrimState m) px) createMutableImage width height background = generateMutableImage (\_ _ -> background) width height -- | Create a mutable image with garbage as content. All data -- is uninitialized. newMutableImage :: forall px m. (Pixel px, PrimMonad m) => Int -- ^ Width -> Int -- ^ Height -> m (MutableImage (PrimState m) px) newMutableImage w h = MutableImage w h `liftM` M.new (w * h * compCount) where compCount = componentCount (undefined :: px) instance NFData (MutableImage s a) where rnf (MutableImage width height dat) = width `seq` height `seq` dat `seq` () -- | 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) -- | A greyscale image with 16bit components | ImageY16 (Image Pixel16) -- | A greyscale HDR image | ImageYF (Image PixelF) -- | An image in greyscale with an alpha channel. | ImageYA8 (Image PixelYA8) -- | An image in greyscale with alpha channel on 16 bits. | ImageYA16 (Image PixelYA16) -- | An image in true color. | ImageRGB8 (Image PixelRGB8) -- | An image in true color with 16bit depth. | ImageRGB16 (Image PixelRGB16) -- | An image with HDR pixels | ImageRGBF (Image PixelRGBF) -- | An image in true color and an alpha channel. | ImageRGBA8 (Image PixelRGBA8) -- | A true color image with alpha on 16 bits. | ImageRGBA16 (Image PixelRGBA16) -- | An image in the colorspace used by Jpeg images. | ImageYCbCr8 (Image PixelYCbCr8) -- | An image in the colorspace CMYK | ImageCMYK8 (Image PixelCMYK8) -- | An image in the colorspace CMYK and 16 bits precision | ImageCMYK16 (Image PixelCMYK16) deriving (Typeable) -- | Type used to expose a palette extracted during reading. -- Use palettedAsImage to convert it to a palette usable for -- writing. data Palette' px = Palette' { -- | Number of element in pixels. _paletteSize :: !Int -- | Real data used by the palette. , _paletteData :: !(V.Vector (PixelBaseComponent px)) } deriving Typeable -- | Convert a palette to an image. Used mainly for -- backward compatibility. palettedAsImage :: Palette' px -> Image px palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p -- | Describe an image and it's potential associated -- palette. If no palette is present, fallback to a -- DynamicImage data PalettedImage = TrueColorImage DynamicImage -- ^ Fallback | PalettedY8 (Image Pixel8) (Palette' Pixel8) | PalettedRGB8 (Image Pixel8) (Palette' PixelRGB8) | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8) | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16) deriving (Typeable) -- | Flatten a PalettedImage to a DynamicImage palettedToTrueColor :: PalettedImage -> DynamicImage palettedToTrueColor img = case img of TrueColorImage d -> d PalettedY8 i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i PalettedRGB8 i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i where toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral) -- | Helper function to help extract information from dynamic -- image. To get the width of a dynamic image, you can use -- the following snippet: -- -- > dynWidth :: DynamicImage -> Int -- > dynWidth img = dynamicMap imageWidth img -- dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a) -> DynamicImage -> a dynamicMap f (ImageY8 i) = f i dynamicMap f (ImageY16 i) = f i dynamicMap f (ImageYF i) = f i dynamicMap f (ImageYA8 i) = f i dynamicMap f (ImageYA16 i) = f i dynamicMap f (ImageRGB8 i) = f i dynamicMap f (ImageRGB16 i) = f i dynamicMap f (ImageRGBF i) = f i dynamicMap f (ImageRGBA8 i) = f i dynamicMap f (ImageRGBA16 i) = f i dynamicMap f (ImageYCbCr8 i) = f i dynamicMap f (ImageCMYK8 i) = f i dynamicMap f (ImageCMYK16 i) = f i -- | Equivalent of the `pixelMap` function for the dynamic images. -- You can perform pixel colorspace independant operations with this -- function. -- -- For instance, if you want to extract a square crop of any image, -- without caring about colorspace, you can use the following snippet. -- -- > dynSquare :: DynamicImage -> DynamicImage -- > dynSquare = dynamicPixelMap squareImage -- > -- > squareImage :: Pixel a => Image a -> Image a -- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge -- > where edge = min (imageWidth img) (imageHeight img) -- dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel) -> DynamicImage -> DynamicImage dynamicPixelMap f = aux where aux (ImageY8 i) = ImageY8 (f i) aux (ImageY16 i) = ImageY16 (f i) aux (ImageYF i) = ImageYF (f i) aux (ImageYA8 i) = ImageYA8 (f i) aux (ImageYA16 i) = ImageYA16 (f i) aux (ImageRGB8 i) = ImageRGB8 (f i) aux (ImageRGB16 i) = ImageRGB16 (f i) aux (ImageRGBF i) = ImageRGBF (f i) aux (ImageRGBA8 i) = ImageRGBA8 (f i) aux (ImageRGBA16 i) = ImageRGBA16 (f i) aux (ImageYCbCr8 i) = ImageYCbCr8 (f i) aux (ImageCMYK8 i) = ImageCMYK8 (f i) aux (ImageCMYK16 i) = ImageCMYK16 (f i) instance NFData DynamicImage where rnf (ImageY8 img) = rnf img rnf (ImageY16 img) = rnf img rnf (ImageYF img) = rnf img rnf (ImageYA8 img) = rnf img rnf (ImageYA16 img) = rnf img rnf (ImageRGB8 img) = rnf img rnf (ImageRGB16 img) = rnf img rnf (ImageRGBF img) = rnf img rnf (ImageRGBA8 img) = rnf img rnf (ImageRGBA16 img) = rnf img rnf (ImageYCbCr8 img) = rnf img rnf (ImageCMYK8 img) = rnf img rnf (ImageCMYK16 img) = rnf img -- | Type alias for 8bit greyscale pixels. For simplicity, -- greyscale pixels use plain numbers instead of a separate type. type Pixel8 = Word8 -- | Type alias for 16bit greyscale pixels. type Pixel16 = Word16 -- | Type alias for 32bit greyscale pixels. type Pixel32 = Word32 -- | Type alias for 32bit floating point greyscale pixels. The standard -- bounded value range is mapped to the closed interval [0,1] i.e. -- -- > map promotePixel [0, 1 .. 255 :: Pixel8] == [0/255, 1/255 .. 1.0 :: PixelF] type PixelF = Float -- | Pixel type storing 8bit Luminance (Y) and alpha (A) information. -- Values are stored in the following order: -- -- * Luminance -- -- * Alpha -- data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8 -- Luminance {-# UNPACK #-} !Pixel8 -- Alpha value deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit Luminance (Y) and alpha (A) information. -- Values are stored in the following order: -- -- * Luminance -- -- * Alpha -- data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16 -- Luminance {-# UNPACK #-} !Pixel16 -- Alpha value deriving (Eq, Ord, Show, Typeable) -- | Classic pixel type storing 8bit red, green and blue (RGB) information. -- Values are stored in the following order: -- -- * Red -- -- * Green -- -- * Blue -- data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red {-# UNPACK #-} !Pixel8 -- Green {-# UNPACK #-} !Pixel8 -- Blue deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing value for the YCCK color space: -- -- * Y (Luminance) -- -- * Cb -- -- * Cr -- -- * Black -- data PixelYCbCrK8 = PixelYCbCrK8 {-# UNPACK #-} !Pixel8 {-# UNPACK #-} !Pixel8 {-# UNPACK #-} !Pixel8 {-# UNPACK #-} !Pixel8 deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit red, green and blue (RGB) information. -- Values are stored in the following order: -- -- * Red -- -- * Green -- -- * Blue -- data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red {-# UNPACK #-} !Pixel16 -- Green {-# UNPACK #-} !Pixel16 -- Blue deriving (Eq, Ord, Show, Typeable) -- | 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 -- -- * Green -- -- * Blue -- data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red {-# UNPACK #-} !PixelF -- Green {-# UNPACK #-} !PixelF -- Blue deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information. -- Values are stored in the following order: -- -- * Y (luminance) -- -- * Cb -- -- * Cr -- data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance {-# UNPACK #-} !Pixel8 -- Cb blue difference {-# UNPACK #-} !Pixel8 -- Cr red difference deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information. -- Values are stored in the following order: -- -- * Cyan -- -- * Magenta -- -- * Yellow -- -- * Black -- data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan {-# UNPACK #-} !Pixel8 -- Magenta {-# UNPACK #-} !Pixel8 -- Yellow {-# UNPACK #-} !Pixel8 -- Black deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information. -- Values are stored in the following order: -- -- * Cyan -- -- * Magenta -- -- * Yellow -- -- * Black -- data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan {-# UNPACK #-} !Pixel16 -- Magenta {-# UNPACK #-} !Pixel16 -- Yellow {-# UNPACK #-} !Pixel16 -- Black deriving (Eq, Ord, Show, Typeable) -- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information. -- Values are stored in the following order: -- -- * Red -- -- * Green -- -- * Blue -- -- * Alpha -- data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red {-# UNPACK #-} !Pixel8 -- Green {-# UNPACK #-} !Pixel8 -- Blue {-# UNPACK #-} !Pixel8 -- Alpha deriving (Eq, Ord, Show, Typeable) -- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information. -- Values are stored in the following order: -- -- * Red -- -- * Green -- -- * Blue -- -- * Alpha -- data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red {-# UNPACK #-} !Pixel16 -- Green {-# UNPACK #-} !Pixel16 -- Blue {-# UNPACK #-} !Pixel16 -- Alpha deriving (Eq, Ord, Show, Typeable) -- | Definition of pixels used in images. Each pixel has a color space, and a representative -- component (Word8 or Float). class ( Storable (PixelBaseComponent a) , Num (PixelBaseComponent a), Eq a ) => Pixel a where -- | Type of the pixel component, "classical" images -- would have Word8 type as their PixelBaseComponent, -- HDR image would have Float for instance type PixelBaseComponent a :: * -- | Call the function for every component of the pixels. -- 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) -- 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. -- -- > mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGB8 rb gb bb ab) = -- > PixelRGBA8 (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 components of the pixel componentCount :: a -> Int -- | 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 pixelBaseIndex :: Image a -> Int -> Int -> Int pixelBaseIndex (Image { imageWidth = w }) x y = (x + y * w) * componentCount (undefined :: a) -- | Calculate theindex for the begining of the pixel at position x y mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = (x + y * w) * componentCount (undefined :: a) -- | Extract a pixel at a given position, (x, y), the origin -- is assumed to be at the corner top left, positive y to the -- bottom of the image pixelAt :: Image a -> Int -> Int -> a -- | Same as pixelAt but for mutable images. readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a -- | Write a pixel in a mutable image at position x y writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m () -- | Unsafe version of pixelAt, read a pixel at the given -- index without bound checking (if possible). -- The index is expressed in number (PixelBaseComponent a) unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a -- | Unsafe version of readPixel, read a pixel at the given -- position without bound checking (if possible). The index -- is expressed in number (PixelBaseComponent a) unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a -- | Unsafe version of writePixel, write a pixel at the -- given position without bound checking. This can be _really_ unsafe. -- The index is expressed in number (PixelBaseComponent a) unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m () -- | Implement upcasting for pixel types. -- Minimal declaration of `promotePixel`. -- It is strongly recommended to overload promoteImage to keep -- performance acceptable class (Pixel a, Pixel b) => ColorConvertible a b where -- | Convert a pixel type to another pixel type. This -- operation should never lose any data. promotePixel :: a -> b -- | Change the underlying pixel type of an image by performing a full copy -- of it. promoteImage :: Image a -> Image b promoteImage = pixelMap promotePixel -- | This class abstract colorspace conversion. This -- conversion can be lossy, which ColorConvertible cannot class (Pixel a, Pixel b) => ColorSpaceConvertible a b where -- | Pass a pixel from a colorspace (say RGB) to the second one -- (say YCbCr) convertPixel :: a -> b -- | Helper function to convert a whole image by taking a -- copy it. convertImage :: Image a -> Image b convertImage = pixelMap convertPixel generateMutableImage :: forall m px. (Pixel px, PrimMonad m) => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. -> Int -- ^ Width in pixels -> Int -- ^ Height in pixels -> m (MutableImage (PrimState m) px) {-# INLINE generateMutableImage #-} generateMutableImage f w h = MutableImage w h `liftM` generated where compCount = componentCount (undefined :: px) generated = do arr <- M.new (w * h * compCount) let lineGenerator _ !y | y >= h = return () lineGenerator !lineIdx y = column lineIdx 0 where column !idx !x | x >= w = lineGenerator idx $ y + 1 column idx x = do unsafeWritePixel arr idx $ f x y column (idx + compCount) $ x + 1 lineGenerator 0 0 return arr -- | Create an image given a function to generate pixels. -- The function will receive values from 0 to width-1 for the x parameter -- 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: -- -- > imageCreator :: String -> IO () -- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 -- > where pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128 -- generateImage :: forall px. (Pixel px) => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. -> Int -- ^ Width in pixels -> Int -- ^ Height in pixels -> Image px {-# INLINE generateImage #-} generateImage f w h = runST img where img :: ST s (Image px) img = generateMutableImage f w h >>= unsafeFreezeImage -- | Create an image using a monadic initializer function. -- The function will receive values from 0 to width-1 for the x parameter -- 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. -- -- The function is called for each pixel in the line from left to right (0 to width - 1) -- and for each line (0 to height - 1). withImage :: forall m pixel. (Pixel pixel, PrimMonad m) => Int -- ^ Image width -> Int -- ^ Image height -> (Int -> Int -> m pixel) -- ^ Generating functions -> m (Image pixel) withImage width height pixelGenerator = do let pixelComponentCount = componentCount (undefined :: pixel) arr <- M.new (width * height * pixelComponentCount) let mutImage = MutableImage { mutableImageWidth = width , mutableImageHeight = height , mutableImageData = arr } let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]] sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]] unsafeFreezeImage mutImage -- | Create an image given a function to generate pixels. -- The function will receive values from 0 to width-1 for the x parameter -- 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. -- -- the acc parameter is a user defined one. -- -- The function is called for each pixel in the line from left to right (0 to width - 1) -- and for each line (0 to height - 1). generateFoldImage :: forall a acc. (Pixel a) => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y -> acc -- ^ Initial state -> Int -- ^ Width in pixels -> Int -- ^ Height in pixels -> (acc, Image a) generateFoldImage f intialAcc w h = (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated }) where compCount = componentCount (undefined :: a) (finalState, generated) = runST $ do arr <- M.new (w * h * compCount) let mutImage = MutableImage { mutableImageWidth = w, mutableImageHeight = h, mutableImageData = arr } foldResult <- foldM (\acc (x,y) -> do let (acc', px) = f acc x y writePixel mutImage x y px return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] frozen <- V.unsafeFreeze arr return (foldResult, frozen) -- | Fold over the pixel of an image with a raster scan order: -- from top to bottom, left to right {-# INLINE pixelFold #-} pixelFold :: forall acc pixel. (Pixel pixel) => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = columnFold 0 initialAccumulator 0 where !compCount = componentCount (undefined :: pixel) !vec = imageData img lfold !y acc !x !idx | x >= w = columnFold (y + 1) acc idx | otherwise = lfold y (f acc x y $ unsafePixelAt vec idx) (x + 1) (idx + compCount) columnFold !y lineAcc !readIdx | y >= h = lineAcc | otherwise = lfold y lineAcc 0 readIdx -- | 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) -- | Fold over the pixel of an image with a raster scan order: -- from top to bottom, left to right. This functions is analog -- to the foldMap from the 'Foldable' typeclass, but due to the -- Pixel constraint, Image cannot be made an instance of it. pixelFoldMap :: forall m px. (Pixel px, Monoid m) => (px -> m) -> Image px -> m pixelFoldMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = folder 0 where compCount = componentCount (undefined :: px) maxi = w * h * compCount folder idx | idx >= maxi = mempty folder idx = f (unsafePixelAt vec idx) <> folder (idx + compCount) -- | `map` equivalent for an image, working at the pixel level. -- Little example : a brightness function for an rgb image -- -- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8 -- > brightnessRGB8 add = pixelMap brightFunction -- > where up v = fromIntegral (fromIntegral v + add) -- > brightFunction (PixelRGB8 r g b) = -- > PixelRGB8 (up r) (up g) (up b) -- pixelMap :: forall a b. (Pixel a, Pixel b) => (a -> b) -> Image a -> Image b {-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-} pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = Image w h pixels where sourceComponentCount = componentCount (undefined :: a) destComponentCount = componentCount (undefined :: b) pixels = runST $ do newArr <- M.new (w * h * destComponentCount) let lineMapper _ _ y | y >= h = return () lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 where colMapper readIdx writeIdx x | x >= w = lineMapper readIdx writeIdx $ y + 1 | otherwise = do unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx colMapper (readIdx + sourceComponentCount) (writeIdx + destComponentCount) (x + 1) lineMapper 0 0 0 -- unsafeFreeze avoids making a second copy and it will be -- safe because newArray can't be referenced as a mutable array -- outside of this where block V.unsafeFreeze newArr -- | Helpers to embed a rankNTypes inside an Applicative newtype GenST a = GenST { genAction :: forall s. ST s (M.STVector s a) } -- | Traversal type matching the definition in the Lens package. type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t writePx :: Pixel px => Int -> GenST (PixelBaseComponent px) -> px -> GenST (PixelBaseComponent px) {-# INLINE writePx #-} writePx idx act px = GenST $ do vec <- genAction act unsafeWritePixel vec idx px return vec freezeGenST :: Pixel px => Int -> Int -> GenST (PixelBaseComponent px) -> Image px freezeGenST w h act = Image w h (runST (genAction act >>= V.unsafeFreeze)) -- | Traversal in "raster" order, from left to right the top to bottom. -- This traversal is matching pixelMap in spirit. -- -- Since 3.2.4 imagePixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) => Traversal (Image pxa) (Image pxb) pxa pxb {-# INLINE imagePixels #-} imagePixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = freezeGenST w h <$> pixels where sourceComponentCount = componentCount (undefined :: pxa) destComponentCount = componentCount (undefined :: pxb) maxi = w * h * sourceComponentCount pixels = go (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 go act readIdx _ | readIdx >= maxi = act go act readIdx writeIdx = go newAct (readIdx + sourceComponentCount) (writeIdx + destComponentCount) where px = f (unsafePixelAt vec readIdx) newAct = writePx writeIdx <$> act <*> px -- | Traversal providing the pixel position with it's value. -- The traversal in raster order, from lef to right, then top -- to bottom. The traversal match pixelMapXY in spirit. -- -- Since 3.2.4 imageIPixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) => Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb {-# INLINE imageIPixels #-} imageIPixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = freezeGenST w h <$> pixels where sourceComponentCount = componentCount (undefined :: pxa) destComponentCount = componentCount (undefined :: pxb) pixels = lineMapper (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 0 lineMapper act _ _ y | y >= h = act lineMapper act readIdxLine writeIdxLine y = go act readIdxLine writeIdxLine 0 where go cact readIdx writeIdx x | x >= w = lineMapper cact readIdx writeIdx $ y + 1 | otherwise = do let px = f (x, y, unsafePixelAt vec readIdx) go (writePx writeIdx <$> cact <*> px) (readIdx + sourceComponentCount) (writeIdx + destComponentCount) (x + 1) -- | Just like `pixelMap` only the function takes the pixel coordinates as -- additional parameters. pixelMapXY :: forall a b. (Pixel a, Pixel b) => (Int -> Int -> a -> b) -> Image a -> Image b {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} {-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} pixelMapXY f Image { imageWidth = w, imageHeight = h, imageData = vec } = Image w h pixels where sourceComponentCount = componentCount (undefined :: a) destComponentCount = componentCount (undefined :: b) pixels = runST $ do newArr <- M.new (w * h * destComponentCount) let lineMapper _ _ y | y >= h = return () lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 where colMapper readIdx writeIdx x | x >= w = lineMapper readIdx writeIdx $ y + 1 | otherwise = do unsafeWritePixel newArr writeIdx . f x y $ unsafePixelAt vec readIdx colMapper (readIdx + sourceComponentCount) (writeIdx + destComponentCount) (x + 1) lineMapper 0 0 0 -- unsafeFreeze avoids making a second copy and it will be -- safe because newArray can't be referenced as a mutable array -- outside of this where block V.unsafeFreeze newArr -- | Combine, pixel by pixel and component by component -- the values of 3 different images. Usage example: -- -- > averageBrightNess c1 c2 c3 = clamp $ toInt c1 + toInt c2 + toInt c3 -- > where clamp = fromIntegral . min 0 . max 255 -- > toInt :: a -> Int -- > toInt = fromIntegral -- > ziPixelComponent3 averageBrightNess img1 img2 img3 -- zipPixelComponent3 :: forall px. ( V.Storable (PixelBaseComponent px)) => (PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px) -> Image px -> Image px -> Image px -> Image px {-# INLINE zipPixelComponent3 #-} zipPixelComponent3 f i1@(Image { imageWidth = w, imageHeight = h }) i2 i3 | not isDimensionEqual = error "Different image size zipPairwisePixelComponent" | otherwise = Image { imageWidth = w , imageHeight = h , imageData = V.zipWith3 f data1 data2 data3 } where data1 = imageData i1 data2 = imageData i2 data3 = imageData i3 isDimensionEqual = w == imageWidth i2 && w == imageWidth i3 && h == imageHeight i2 && h == imageHeight i3 -- | Helper class to help extract a luma plane out -- 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 -- | Extract a luma plane out of an image. This -- method is in the typeclass to help performant -- implementation. -- -- > jpegToGrayScale :: FilePath -> FilePath -> IO () -- > jpegToGrayScale source dest extractLumaPlane :: Image a -> Image (PixelBaseComponent a) extractLumaPlane = pixelMap computeLuma instance LumaPlaneExtractable Pixel8 where {-# INLINE computeLuma #-} computeLuma = id extractLumaPlane = id instance LumaPlaneExtractable Pixel16 where {-# INLINE computeLuma #-} computeLuma = id extractLumaPlane = id instance LumaPlaneExtractable Pixel32 where {-# INLINE computeLuma #-} computeLuma = id extractLumaPlane = id instance LumaPlaneExtractable PixelF where {-# INLINE computeLuma #-} computeLuma = id extractLumaPlane = id instance LumaPlaneExtractable PixelRGBF where {-# INLINE computeLuma #-} computeLuma (PixelRGBF r g b) = 0.3 * r + 0.59 * g + 0.11 * b instance LumaPlaneExtractable PixelRGBA8 where {-# INLINE computeLuma #-} computeLuma (PixelRGBA8 r g b _) = floor $ (0.3 :: Double) * fromIntegral r + 0.59 * fromIntegral g + 0.11 * fromIntegral b instance LumaPlaneExtractable PixelYCbCr8 where {-# INLINE computeLuma #-} computeLuma (PixelYCbCr8 y _ _) = y extractLumaPlane = extractComponent PlaneLuma -- | Free promotion for identic pixel types instance (Pixel a) => ColorConvertible a a where {-# INLINE promotePixel #-} promotePixel = id {-# INLINE promoteImage #-} promoteImage = id -------------------------------------------------- ---- Pixel8 instances -------------------------------------------------- instance Pixel Pixel8 where type PixelBaseComponent Pixel8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f = f 0 {-# INLINE colorMap #-} colorMap f = f {-# INLINE componentCount #-} componentCount _ = 1 {-# INLINE pixelAt #-} pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.read` mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.write` mutablePixelBaseIndex image x y {-# INLINE unsafePixelAt #-} unsafePixelAt = V.unsafeIndex {-# INLINE unsafeReadPixel #-} unsafeReadPixel = M.unsafeRead {-# INLINE unsafeWritePixel #-} unsafeWritePixel = M.unsafeWrite instance ColorConvertible Pixel8 PixelYA8 where {-# INLINE promotePixel #-} promotePixel c = PixelYA8 c 255 instance ColorConvertible Pixel8 PixelF where {-# INLINE promotePixel #-} promotePixel c = fromIntegral c / 255.0 instance ColorConvertible Pixel8 Pixel16 where {-# INLINE promotePixel #-} promotePixel c = fromIntegral c * 257 instance ColorConvertible Pixel8 PixelRGB8 where {-# INLINE promotePixel #-} promotePixel c = PixelRGB8 c c c instance ColorConvertible Pixel8 PixelRGBA8 where {-# INLINE promotePixel #-} promotePixel c = PixelRGBA8 c c c 255 -------------------------------------------------- ---- Pixel16 instances -------------------------------------------------- instance Pixel Pixel16 where type PixelBaseComponent Pixel16 = Word16 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f = f 0 {-# INLINE colorMap #-} colorMap f = f {-# INLINE componentCount #-} componentCount _ = 1 {-# INLINE pixelAt #-} pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.read` mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.write` mutablePixelBaseIndex image x y {-# INLINE unsafePixelAt #-} unsafePixelAt = V.unsafeIndex {-# INLINE unsafeReadPixel #-} unsafeReadPixel = M.unsafeRead {-# INLINE unsafeWritePixel #-} unsafeWritePixel = M.unsafeWrite instance ColorConvertible Pixel16 PixelYA16 where {-# INLINE promotePixel #-} promotePixel c = PixelYA16 c maxBound instance ColorConvertible Pixel16 PixelRGB16 where {-# INLINE promotePixel #-} promotePixel c = PixelRGB16 c c c instance ColorConvertible Pixel16 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel c = PixelRGBA16 c c c maxBound -------------------------------------------------- ---- Pixel32 instances -------------------------------------------------- instance Pixel Pixel32 where type PixelBaseComponent Pixel32 = Word32 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f = f 0 {-# INLINE colorMap #-} colorMap f = f {-# INLINE componentCount #-} componentCount _ = 1 {-# INLINE pixelAt #-} pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.read` mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.write` mutablePixelBaseIndex image x y {-# INLINE unsafePixelAt #-} unsafePixelAt = V.unsafeIndex {-# INLINE unsafeReadPixel #-} unsafeReadPixel = M.unsafeRead {-# INLINE unsafeWritePixel #-} unsafeWritePixel = M.unsafeWrite -------------------------------------------------- ---- PixelF instances -------------------------------------------------- instance Pixel PixelF where type PixelBaseComponent PixelF = Float {-# INLINE pixelOpacity #-} pixelOpacity = const 1.0 {-# INLINE mixWith #-} mixWith f = f 0 {-# INLINE colorMap #-} colorMap f = f {-# INLINE componentCount #-} componentCount _ = 1 {-# INLINE pixelAt #-} pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.read` mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y = arr `M.write` mutablePixelBaseIndex image x y {-# INLINE unsafePixelAt #-} unsafePixelAt = V.unsafeIndex {-# INLINE unsafeReadPixel #-} unsafeReadPixel = M.unsafeRead {-# INLINE unsafeWritePixel #-} unsafeWritePixel = M.unsafeWrite instance ColorConvertible PixelF PixelRGBF where {-# INLINE promotePixel #-} promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59) (c / 0.11) -------------------------------------------------- ---- PixelYA8 instances -------------------------------------------------- instance Pixel PixelYA8 where type PixelBaseComponent PixelYA8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity (PixelYA8 _ a) = a {-# INLINE mixWith #-} mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) = PixelYA8 (f 0 ya yb) (f 1 aa ab) {-# INLINE colorMap #-} colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a) {-# INLINE componentCount #-} componentCount _ = 2 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelYA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do yv <- arr `M.read` baseIdx av <- arr `M.read` (baseIdx + 1) return $ PixelYA8 yv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) yv (arr `M.write` (baseIdx + 1)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelYA8 y a) = M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a instance ColorConvertible PixelYA8 PixelRGB8 where {-# INLINE promotePixel #-} promotePixel (PixelYA8 y _) = PixelRGB8 y y y instance ColorConvertible PixelYA8 PixelRGBA8 where {-# INLINE promotePixel #-} promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a instance ColorPlane PixelYA8 PlaneLuma where toComponentIndex _ _ = 0 instance ColorPlane PixelYA8 PlaneAlpha where toComponentIndex _ _ = 1 instance TransparentPixel PixelYA8 Pixel8 where {-# INLINE dropTransparency #-} dropTransparency (PixelYA8 y _) = y {-# INLINE getTransparency #-} getTransparency (PixelYA8 _ a) = a instance LumaPlaneExtractable PixelYA8 where {-# INLINE computeLuma #-} computeLuma (PixelYA8 y _) = y extractLumaPlane = extractComponent PlaneLuma -------------------------------------------------- ---- PixelYA16 instances -------------------------------------------------- instance Pixel PixelYA16 where type PixelBaseComponent PixelYA16 = Word16 {-# INLINE pixelOpacity #-} pixelOpacity (PixelYA16 _ a) = a {-# INLINE mixWith #-} 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) {-# INLINE componentCount #-} componentCount _ = 2 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do yv <- arr `M.read` baseIdx av <- arr `M.read` (baseIdx + 1) return $ PixelYA16 yv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) yv (arr `M.write` (baseIdx + 1)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelYA16 y a) = M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a instance ColorConvertible PixelYA16 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a instance ColorPlane PixelYA16 PlaneLuma where toComponentIndex _ _ = 0 instance ColorPlane PixelYA16 PlaneAlpha where toComponentIndex _ _ = 1 instance TransparentPixel PixelYA16 Pixel16 where {-# INLINE dropTransparency #-} dropTransparency (PixelYA16 y _) = y {-# INLINE getTransparency #-} getTransparency (PixelYA16 _ a) = a -------------------------------------------------- ---- PixelRGBF instances -------------------------------------------------- instance Pixel PixelRGBF where type PixelBaseComponent PixelRGBF = PixelF {-# INLINE pixelOpacity #-} pixelOpacity = const 1.0 {-# INLINE mixWith #-} mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) = PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) {-# INLINE colorMap #-} colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b) {-# INLINE componentCount #-} componentCount _ = 3 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) return $ PixelRGBF rv gv bv where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelRGBF `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelRGBF r g b) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b instance ColorPlane PixelRGBF PlaneRed where toComponentIndex _ _ = 0 instance ColorPlane PixelRGBF PlaneGreen where toComponentIndex _ _ = 1 instance ColorPlane PixelRGBF PlaneBlue where toComponentIndex _ _ = 2 -------------------------------------------------- ---- PixelRGB16 instances -------------------------------------------------- instance Pixel PixelRGB16 where type PixelBaseComponent PixelRGB16 = Pixel16 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) = PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) {-# INLINE colorMap #-} colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) {-# INLINE componentCount #-} componentCount _ = 3 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) return $ PixelRGB16 rv gv bv where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelRGB16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelRGB16 r g b) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b instance ColorPlane PixelRGB16 PlaneRed where toComponentIndex _ _ = 0 instance ColorPlane PixelRGB16 PlaneGreen where toComponentIndex _ _ = 1 instance ColorPlane PixelRGB16 PlaneBlue where toComponentIndex _ _ = 2 instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where {-# INLINE convertPixel #-} convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b) instance ColorConvertible PixelRGB16 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound instance LumaPlaneExtractable PixelRGB16 where {-# INLINE computeLuma #-} computeLuma (PixelRGB16 r g b) = floor $ (0.3 :: Double) * fromIntegral r + 0.59 * fromIntegral g + 0.11 * fromIntegral b -------------------------------------------------- ---- PixelRGB8 instances -------------------------------------------------- instance Pixel PixelRGB8 where type PixelBaseComponent PixelRGB8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) {-# INLINE colorMap #-} colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b) {-# INLINE componentCount #-} componentCount _ = 3 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) return $ PixelRGB8 rv gv bv where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelRGB8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelRGB8 r g b) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b instance ColorConvertible PixelRGB8 PixelRGBA8 where {-# INLINE promotePixel #-} promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound instance ColorConvertible PixelRGB8 PixelRGBF where {-# INLINE promotePixel #-} promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) where toF v = fromIntegral v / 255.0 instance ColorConvertible PixelRGB8 PixelRGB16 where {-# INLINE promotePixel #-} promotePixel (PixelRGB8 r g b) = PixelRGB16 (promotePixel r) (promotePixel g) (promotePixel b) instance ColorConvertible PixelRGB8 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel (PixelRGB8 r g b) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) maxBound instance ColorPlane PixelRGB8 PlaneRed where toComponentIndex _ _ = 0 instance ColorPlane PixelRGB8 PlaneGreen where toComponentIndex _ _ = 1 instance ColorPlane PixelRGB8 PlaneBlue where toComponentIndex _ _ = 2 instance LumaPlaneExtractable PixelRGB8 where {-# INLINE computeLuma #-} computeLuma (PixelRGB8 r g b) = floor $ (0.3 :: Double) * fromIntegral r + 0.59 * fromIntegral g + 0.11 * fromIntegral b -------------------------------------------------- ---- PixelRGBA8 instances -------------------------------------------------- instance Pixel PixelRGBA8 where type PixelBaseComponent PixelRGBA8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity (PixelRGBA8 _ _ _ a) = a {-# INLINE mixWith #-} 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) {-# INLINE componentCount #-} componentCount _ = 4 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) av <- arr `M.read` (baseIdx + 3) return $ PixelRGBA8 rv gv bv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv (arr `M.write` (baseIdx + 3)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelRGBA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) (V.unsafeIndex v $ idx + 3) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelRGBA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) `ap` M.unsafeRead vec (idx + 3) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelRGBA8 r g b a) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b >> M.unsafeWrite v (idx + 3) a instance ColorConvertible PixelRGBA8 PixelRGBA16 where {-# INLINE promotePixel #-} promotePixel (PixelRGBA8 r g b a) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) (promotePixel a) instance ColorPlane PixelRGBA8 PlaneRed where toComponentIndex _ _ = 0 instance ColorPlane PixelRGBA8 PlaneGreen where toComponentIndex _ _ = 1 instance ColorPlane PixelRGBA8 PlaneBlue where toComponentIndex _ _ = 2 instance ColorPlane PixelRGBA8 PlaneAlpha where toComponentIndex _ _ = 3 -------------------------------------------------- ---- PixelRGBA16 instances -------------------------------------------------- instance Pixel PixelRGBA16 where type PixelBaseComponent PixelRGBA16 = Pixel16 {-# INLINE pixelOpacity #-} pixelOpacity (PixelRGBA16 _ _ _ a) = a {-# 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) {-# INLINE componentCount #-} componentCount _ = 4 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) av <- arr `M.read` (baseIdx + 3) return $ PixelRGBA16 rv gv bv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv (arr `M.write` (baseIdx + 3)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelRGBA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) (V.unsafeIndex v $ idx + 3) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelRGBA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) `ap` M.unsafeRead vec (idx + 3) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelRGBA16 r g b a) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b >> M.unsafeWrite v (idx + 3) a instance TransparentPixel PixelRGBA16 PixelRGB16 where {-# INLINE dropTransparency #-} dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b {-# INLINE getTransparency #-} getTransparency (PixelRGBA16 _ _ _ a) = a instance ColorPlane PixelRGBA16 PlaneRed where toComponentIndex _ _ = 0 instance ColorPlane PixelRGBA16 PlaneGreen where toComponentIndex _ _ = 1 instance ColorPlane PixelRGBA16 PlaneBlue where toComponentIndex _ _ = 2 instance ColorPlane PixelRGBA16 PlaneAlpha where toComponentIndex _ _ = 3 -------------------------------------------------- ---- PixelYCbCr8 instances -------------------------------------------------- instance Pixel PixelYCbCr8 where type PixelBaseComponent PixelYCbCr8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) = PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) {-# INLINE colorMap #-} colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr) {-# INLINE componentCount #-} componentCount _ = 3 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do yv <- arr `M.read` baseIdx cbv <- arr `M.read` (baseIdx + 1) crv <- arr `M.read` (baseIdx + 2) return $ PixelYCbCr8 yv cbv crv where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) yv (arr `M.write` (baseIdx + 1)) cbv (arr `M.write` (baseIdx + 2)) crv {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelYCbCr8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelYCbCr8 y cb cr) = M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb >> M.unsafeWrite v (idx + 2) cr instance (Pixel a) => ColorSpaceConvertible a a where convertPixel = id convertImage = id scaleBits, oneHalf :: Int scaleBits = 16 oneHalf = 1 `unsafeShiftL` (scaleBits - 1) fix :: Float -> Int fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5 rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ] gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ] bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ] rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ] gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ] bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ] gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ] bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ] instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where {-# INLINE convertPixel #-} convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr) where ri = fromIntegral r gi = fromIntegral g bi = fromIntegral b y = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData where maxi = w * h rY = fix 0.29900 gY = fix 0.58700 bY = fix 0.11400 rCb = - fix 0.16874 gCb = - fix 0.33126 bCb = fix 0.5 gCr = - fix 0.41869 bCr = - fix 0.08131 newData = runST $ do block <- M.new $ maxi * 3 let traductor _ idx | idx >= maxi = return block traductor readIdx idx = do let ri = fromIntegral $ d `V.unsafeIndex` readIdx gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) y = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr traductor (readIdx + 3) (idx + 1) traductor 0 0 >>= V.freeze crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]] cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]] instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where {-# INLINE convertPixel #-} convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) where clampWord8 = fromIntegral . max 0 . min 255 yi = fromIntegral y cbi = fromIntegral cb cri = fromIntegral cr r = yi + crRTab `V.unsafeIndex` cri g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits b = yi + cbBTab `V.unsafeIndex` cbi convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData where maxi = w * h clampWord8 v | v < 0 = 0 | v > 255 = 255 | otherwise = fromIntegral v newData = runST $ do block <- M.new $ maxi * 3 let traductor _ idx | idx >= maxi = return block traductor readIdx idx = do let yi = fromIntegral $ d `V.unsafeIndex` readIdx cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) r = yi + crRTab `V.unsafeIndex` cri g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits b = yi + cbBTab `V.unsafeIndex` cbi (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b traductor (readIdx + 3) (idx + 1) traductor 0 0 >>= V.freeze instance ColorPlane PixelYCbCr8 PlaneLuma where toComponentIndex _ _ = 0 instance ColorPlane PixelYCbCr8 PlaneCb where toComponentIndex _ _ = 1 instance ColorPlane PixelYCbCr8 PlaneCr where toComponentIndex _ _ = 2 -------------------------------------------------- ---- PixelCMYK8 instances -------------------------------------------------- instance Pixel PixelCMYK8 where type PixelBaseComponent PixelCMYK8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) = PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) {-# INLINE colorMap #-} colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k) {-# INLINE componentCount #-} componentCount _ = 4 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) av <- arr `M.read` (baseIdx + 3) return $ PixelCMYK8 rv gv bv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv (arr `M.write` (baseIdx + 3)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelCMYK8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) (V.unsafeIndex v $ idx + 3) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelCMYK8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) `ap` M.unsafeRead vec (idx + 3) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelCMYK8 r g b a) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b >> M.unsafeWrite v (idx + 3) a instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where convertPixel (PixelCMYK8 c m y k) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) where clampWord8 = fromIntegral . max 0 . min 255 . (`div` 255) ik :: Int ik = 255 - fromIntegral k r = (255 - fromIntegral c) * ik g = (255 - fromIntegral m) * ik b = (255 - fromIntegral y) * ik -------------------------------------------------- ---- PixelYCbCrK8 instances -------------------------------------------------- instance Pixel PixelYCbCrK8 where type PixelBaseComponent PixelYCbCrK8 = Word8 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelYCbCrK8 ya cba cra ka) (PixelYCbCrK8 yb cbb crb kb) = PixelYCbCrK8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) (f 3 ka kb) {-# INLINE colorMap #-} colorMap f (PixelYCbCrK8 y cb cr k) = PixelYCbCrK8 (f y) (f cb) (f cr) (f k) {-# INLINE componentCount #-} componentCount _ = 4 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelYCbCrK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do yv <- arr `M.read` baseIdx cbv <- arr `M.read` (baseIdx + 1) crv <- arr `M.read` (baseIdx + 2) kv <- arr `M.read` (baseIdx + 3) return $ PixelYCbCrK8 yv cbv crv kv where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCrK8 yv cbv crv kv) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) yv (arr `M.write` (baseIdx + 1)) cbv (arr `M.write` (baseIdx + 2)) crv (arr `M.write` (baseIdx + 3)) kv {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelYCbCrK8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) (V.unsafeIndex v $ idx + 3) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelYCbCrK8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) `ap` M.unsafeRead vec (idx + 3) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelYCbCrK8 y cb cr k) = M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb >> M.unsafeWrite v (idx + 2) cr >> M.unsafeWrite v (idx + 3) k instance ColorSpaceConvertible PixelYCbCrK8 PixelRGB8 where convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b) where tof :: Word8 -> Float tof = fromIntegral clamp :: Float -> Word8 clamp = floor . max 0 . min 255 yf = tof y r = yf + 1.402 * tof cr - 179.456 g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 b = yf + 1.772 * tof cb - 226.816 instance ColorSpaceConvertible PixelYCbCrK8 PixelCMYK8 where convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k where tof :: Word8 -> Float tof = fromIntegral clamp :: Float -> Word8 clamp = floor . max 0 . min 255 yf = tof y r = yf + 1.402 * tof cr - 179.456 g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 b = yf + 1.772 * tof cb - 226.816 c = clamp $ 255 - r m = clamp $ 255 - g ye = clamp $ 255 - b {-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b) -> (Word8, Word8, Word8) -> b #-} {-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b) -> (Word16, Word16, Word16) -> b #-} integralRGBToCMYK :: (Bounded a, Integral a) => (a -> a -> a -> a -> b) -- ^ Pixel building function -> (a, a, a) -- ^ RGB sample -> b -- ^ Resulting sample integralRGBToCMYK build (r, g, b) = build (clamp c) (clamp m) (clamp y) (fromIntegral kInt) where maxi = maxBound ir = fromIntegral $ maxi - r :: Int ig = fromIntegral $ maxi - g ib = fromIntegral $ maxi - b kInt = minimum [ir, ig, ib] ik = fromIntegral maxi - kInt c = (ir - kInt) `div` ik m = (ig - kInt) `div` ik y = (ib - kInt) `div` ik clamp = fromIntegral . max 0 instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) instance ColorPlane PixelCMYK8 PlaneCyan where toComponentIndex _ _ = 0 instance ColorPlane PixelCMYK8 PlaneMagenta where toComponentIndex _ _ = 1 instance ColorPlane PixelCMYK8 PlaneYellow where toComponentIndex _ _ = 2 instance ColorPlane PixelCMYK8 PlaneBlack where toComponentIndex _ _ = 3 -------------------------------------------------- ---- PixelCMYK16 instances -------------------------------------------------- instance Pixel PixelCMYK16 where type PixelBaseComponent PixelCMYK16 = Word16 {-# INLINE pixelOpacity #-} pixelOpacity = const maxBound {-# INLINE mixWith #-} mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) = PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) {-# INLINE colorMap #-} colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k) {-# INLINE componentCount #-} componentCount _ = 4 {-# INLINE pixelAt #-} pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) where baseIdx = pixelBaseIndex image x y {-# INLINE readPixel #-} readPixel image@(MutableImage { mutableImageData = arr }) x y = do rv <- arr `M.read` baseIdx gv <- arr `M.read` (baseIdx + 1) bv <- arr `M.read` (baseIdx + 2) av <- arr `M.read` (baseIdx + 3) return $ PixelCMYK16 rv gv bv av where baseIdx = mutablePixelBaseIndex image x y {-# INLINE writePixel #-} writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do let baseIdx = mutablePixelBaseIndex image x y (arr `M.write` (baseIdx + 0)) rv (arr `M.write` (baseIdx + 1)) gv (arr `M.write` (baseIdx + 2)) bv (arr `M.write` (baseIdx + 3)) av {-# INLINE unsafePixelAt #-} unsafePixelAt v idx = PixelCMYK16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) (V.unsafeIndex v $ idx + 3) {-# INLINE unsafeReadPixel #-} unsafeReadPixel vec idx = PixelCMYK16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) `ap` M.unsafeRead vec (idx + 2) `ap` M.unsafeRead vec (idx + 3) {-# INLINE unsafeWritePixel #-} unsafeWritePixel v idx (PixelCMYK16 r g b a) = M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g >> M.unsafeWrite v (idx + 2) b >> M.unsafeWrite v (idx + 3) a instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where convertPixel (PixelCMYK16 c m y k) = PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b) where clampWord16 = fromIntegral . (`unsafeShiftR` 16) ik :: Int ik = 65535 - fromIntegral k r = (65535 - fromIntegral c) * ik g = (65535 - fromIntegral m) * ik b = (65535 - fromIntegral y) * ik instance ColorPlane PixelCMYK16 PlaneCyan where toComponentIndex _ _ = 0 instance ColorPlane PixelCMYK16 PlaneMagenta where toComponentIndex _ _ = 1 instance ColorPlane PixelCMYK16 PlaneYellow where toComponentIndex _ _ = 2 instance ColorPlane PixelCMYK16 PlaneBlack where toComponentIndex _ _ = 3 -- | Perform a gamma correction for an image with HDR pixels. gammaCorrection :: PixelF -- ^ Gamma value, should be between 0.5 and 3.0 -> Image PixelRGBF -- ^ Image to treat. -> Image PixelRGBF gammaCorrection gammaVal = pixelMap gammaCorrector where gammaExponent = 1.0 / gammaVal fixVal v = v ** gammaExponent gammaCorrector (PixelRGBF r g b) = PixelRGBF (fixVal r) (fixVal g) (fixVal b) -- | Perform a tone mapping operation on an High dynamic range image. toneMapping :: PixelF -- ^ Exposure parameter -> Image PixelRGBF -- ^ Image to treat. -> Image PixelRGBF toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0); maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img scaledData = V.map (* coeff) $ imageData img -------------------------------------------------- ---- Packable pixel -------------------------------------------------- -- | This typeclass exist for performance reason, it allow -- to pack a pixel value to a simpler "primitive" data -- type to allow faster writing to moemory. class PackeablePixel a where -- | Primitive type asociated to the current pixel -- It's Word32 for PixelRGBA8 for instance type PackedRepresentation a -- | The packing function, allowing to transform -- 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)) .|. (fi b `unsafeShiftL` (2 * bitCount)) .|. (fi a `unsafeShiftL` (3 * bitCount)) 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)) .|. (fi b `unsafeShiftL` (2 * bitCount)) .|. (fi a `unsafeShiftL` (3 * bitCount)) 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)) .|. (fi y `unsafeShiftL` (2 * bitCount)) .|. (fi k `unsafeShiftL` (3 * bitCount)) 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)) .|. (fi y `unsafeShiftL` (2 * bitCount)) .|. (fi k `unsafeShiftL` (3 * bitCount)) 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 , PrimMonad m , M.Storable (PackedRepresentation px)) => MutableImage (PrimState m) px -> px -> m () fillImageWith img px = M.set converted $ packPixel px where (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img !packedPtr = castForeignPtr ptr !converted = M.unsafeFromForeignPtr packedPtr s (s2 `div` componentCount px) -- | Fill a packeable pixel between two bounds. unsafeWritePixelBetweenAt :: ( PrimMonad m , Pixel px, PackeablePixel px , M.Storable (PackedRepresentation px)) => MutableImage (PrimState m) px -- ^ Image to write into -> px -- ^ Pixel to write -> Int -- ^ Start index in pixel base component -> Int -- ^ pixel count of pixel to write -> m () unsafeWritePixelBetweenAt img px start count = M.set converted packed where !packed = packPixel px !pixelData = mutableImageData img !toSet = M.slice start count pixelData (ptr, s, s2) = M.unsafeToForeignPtr toSet !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 , M.Storable (PackedRepresentation px) , PrimMonad m ) => MutableImage (PrimState m) px -- ^ Image to write into -> Int -- ^ Index in (PixelBaseComponent px) count -> px -- ^ Pixel to write -> m () {-# INLINE writePackedPixelAt #-} writePackedPixelAt img idx px = M.unsafeWrite converted (idx `div` compCount) packed where !packed = packPixel px !compCount = componentCount px (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img !packedPtr = castForeignPtr ptr !converted = M.unsafeFromForeignPtr packedPtr s s2 {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/ColorQuant.hs0000644000000000000000000003402712763010461020032 0ustar0000000000000000{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} -- | 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 -- make everything to create a nice color indexed image -- with its palette. module Codec.Picture.ColorQuant ( palettize , defaultPaletteOptions , PaletteCreationMethod(..) , PaletteOptions( .. ) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative (Applicative (..), (<$>)) #endif import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.), (.|.)) import Data.List (elemIndex) import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import Data.Word (Word32) import Data.Vector (Vector, (!)) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Storable as VS import Codec.Picture.Types ------------------------------------------------------------------------------- ---- Palette Creation and Dithering ------------------------------------------------------------------------------- -- | Define which palette creation method is used. data PaletteCreationMethod = -- | MedianMeanCut method, provide the best results (visualy) -- at the cost of increased calculations. MedianMeanCut -- | Very fast algorithm (one pass), doesn't provide good -- looking results. | Uniform -- | To specify how the palette will be created. data PaletteOptions = PaletteOptions { -- | Algorithm used to find the palette paletteCreationMethod :: PaletteCreationMethod -- | Do we want to apply the dithering to the -- image. Enabling it often reduce compression -- ratio but enhance the perceived quality -- of the final image. , enableImageDithering :: Bool -- | Maximum number of color we want in the -- palette , paletteColorCount :: Int } -- | Default palette option, which aim at the best quality -- and maximum possible colors (256) defaultPaletteOptions :: PaletteOptions defaultPaletteOptions = PaletteOptions { paletteCreationMethod = MedianMeanCut , enableImageDithering = True , paletteColorCount = 256 } -- | Reduces an image to a color palette according to `PaletteOpts` and -- returns the /indices image/ along with its `Palette`. palettize :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) palettize opts@PaletteOptions { paletteCreationMethod = method } = case method of MedianMeanCut -> medianMeanCutQuantization opts Uniform -> uniformQuantization opts -- | Modified median cut algorithm with optional ordered dithering. Returns an -- image of `Pixel8` that acts as a matrix of indices into the `Palette`. medianMeanCutQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) medianMeanCutQuantization opts img | isBelow = (pixelMap okPaletteIndex img, vecToPalette okPaletteVec) | enableImageDithering opts = (pixelMap paletteIndex dImg, palette) | otherwise = (pixelMap paletteIndex img, palette) where maxColorCount = paletteColorCount opts (okPalette, isBelow) = isColorCountBelow maxColorCount img okPaletteVec = V.fromList $ Set.toList okPalette okPaletteIndex p = nearestColorIdx p okPaletteVec palette = vecToPalette paletteVec paletteIndex p = nearestColorIdx p paletteVec paletteVec = mkPaletteVec cs cs = Set.toList . clusters maxColorCount $ img dImg = pixelMapXY dither img -- | A naive one pass Color Quantiation algorithm - Uniform Quantization. -- Simply take the most significant bits. The maxCols parameter is rounded -- down to the nearest power of 2, and the bits are divided among the three -- color channels with priority order green, red, blue. Returns an -- image of `Pixel8` that acts as a matrix of indices into the `Palette`. uniformQuantization :: PaletteOptions -> Image PixelRGB8 -> (Image Pixel8, Palette) uniformQuantization opts img -- -| colorCount img <= maxCols = colorQuantExact img | enableImageDithering opts = (pixelMap paletteIndex (pixelMapXY dither img), palette) | otherwise = (pixelMap paletteIndex img, palette) where maxCols = paletteColorCount opts palette = listToPalette paletteList paletteList = [PixelRGB8 r g b | r <- [0,dr..255] , g <- [0,dg..255] , b <- [0,db..255]] (bg, br, bb) = bitDiv3 maxCols (dr, dg, db) = (2^(8-br), 2^(8-bg), 2^(8-bb)) paletteIndex (PixelRGB8 r g b) = fromIntegral $ fromMaybe 0 (elemIndex (PixelRGB8 (r .&. (255 - dr)) (g .&. (255 - dg)) (b .&. (255 - db))) paletteList) isColorCountBelow :: Int -> Image PixelRGB8 -> (Set.Set PixelRGB8, Bool) isColorCountBelow maxColorCount img = go 0 Set.empty where rawData = imageData img maxIndex = VS.length rawData go !idx !allColors | Set.size allColors > maxColorCount = (Set.empty, False) | idx >= maxIndex - 2 = (allColors, True) | otherwise = go (idx + 3) $ Set.insert px allColors where px = unsafePixelAt rawData idx vecToPalette :: Vector PixelRGB8 -> Palette vecToPalette ps = generateImage (\x _ -> ps ! x) (V.length ps) 1 listToPalette :: [PixelRGB8] -> Palette listToPalette ps = generateImage (\x _ -> ps !! x) (length ps) 1 bitDiv3 :: Int -> (Int, Int, Int) bitDiv3 n = case r of 0 -> (q, q, q) 1 -> (q+1, q, q) _ -> (q+1, q+1, q) where r = m `mod` 3 q = m `div` 3 m = floor . logBase (2 :: Double) $ fromIntegral n ------------------------------------------------------------------------------- ---- Dithering ------------------------------------------------------------------------------- -- Add a dither mask to an image for ordered dithering. -- Uses a small, spatially stable dithering algorithm based on magic numbers -- and arithmetic inspired by the /a dither/ algorithm of Øyvind KolÃ¥s, -- pippin@gimp.org, 2013. See, http://pippin.gimp.org/a_dither/. dither :: Int -> Int -> PixelRGB8 -> PixelRGB8 dither x y (PixelRGB8 r g b) = PixelRGB8 (fromIntegral r') (fromIntegral g') (fromIntegral b') where -- Should view 16 as a parameter that can be optimized for best looking -- results r' = min 255 (fromIntegral r + (x' + y') .&. 16) g' = min 255 (fromIntegral g + (x' + y' + 7973) .&. 16) b' = min 255 (fromIntegral b + (x' + y' + 15946) .&. 16) x' = 119 * x y' = 28084 * y ------------------------------------------------------------------------------- ---- Small modification of foldl package by Gabriel Gonzalez ------------------------------------------------------------------------------- -- Modification to Control.foldl by Gabriel Gonzalez copyright 2013, BSD3. -- http://hackage.haskell.org/package/foldl-1.0.1/docs/Control-Foldl.html {-| Efficient representation of a left fold that preserves the fold's step function, initial accumulator, and extraction function This allows the 'Applicative' instance to assemble derived folds that traverse the container only once -} data Fold a b = forall x . Fold (x -> a -> x) x (x -> b) {-| Apply a strict left 'Fold' to a 'Foldable' container Much slower than 'fold' on lists because 'Foldable' operations currently do not trigger @build/foldr@ fusion -} fold :: Fold PackedRGB b -> VU.Vector PackedRGB -> b fold (Fold step begin done) = done . VU.foldl' step begin {-# INLINE fold #-} {- F.foldr :: (a -> b -> b) -> b -> t a -> b fold :: (Foldable f) => Fold a b -> f a -> b fold (Fold step begin done) as = F.foldr step' done as begin where step' x k z = k $! step z x -} data Pair a b = Pair !a !b instance Functor (Fold a) where fmap f (Fold step begin done) = Fold step begin (f . done) {-# INLINABLE fmap #-} instance Applicative (Fold a) where pure b = Fold (\() _ -> ()) () (\() -> b) {-# INLINABLE pure #-} (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 in Fold step begin done {-# INLINABLE (<*>) #-} {- | Like 'length', except with a more general 'Num' return value -} intLength :: Fold a Int intLength = Fold (\n _ -> n + 1) 0 id ------------------------------------------------------------------------------- ---- Modified Median Cut Algorithm ------------------------------------------------------------------------------- -- Based on the OCaml implementation: -- http://rosettacode.org/wiki/Color_quantization -- which is in turn based on: www.leptonica.com/papers/mediancut.pdf. -- We use the product of volume and population to determine the next cluster -- to split and determine the placement of each color by compating it to the -- mean of the parent cluster. So median cut is a bit of a misnomer, since one -- of the modifiations is to use the mean. mkPaletteVec :: [Cluster] -> Vector PixelRGB8 mkPaletteVec = V.fromList . map (toRGB8 . meanColor) type PackedRGB = Word32 data Cluster = Cluster { value :: {-# UNPACK #-} !Float , meanColor :: !PixelRGBF , dims :: !PixelRGBF , colors :: VU.Vector PackedRGB } instance Eq Cluster where a == b = (value a, meanColor a, dims a) == (value b, meanColor b, dims b) instance Ord Cluster where compare a b = compare (value a, meanColor a, dims a) (value b, meanColor b, dims b) data Axis = RAxis | GAxis | BAxis inf :: Float inf = read "Infinity" fromRGB8 :: PixelRGB8 -> PixelRGBF fromRGB8 (PixelRGB8 r g b) = PixelRGBF (fromIntegral r) (fromIntegral g) (fromIntegral b) toRGB8 :: PixelRGBF -> PixelRGB8 toRGB8 (PixelRGBF r g b) = PixelRGB8 (round r) (round g) (round b) meanRGB :: Fold PixelRGBF PixelRGBF meanRGB = mean <$> intLength <*> pixelSum where pixelSum = Fold (mixWith $ const (+)) (PixelRGBF 0 0 0) id mean n = colorMap (/ nf) where nf = fromIntegral n minimal :: Fold PixelRGBF PixelRGBF minimal = Fold mini (PixelRGBF inf inf inf) id where mini = mixWith $ const min maximal :: Fold PixelRGBF PixelRGBF maximal = Fold maxi (PixelRGBF (-inf) (-inf) (-inf)) id where maxi = mixWith $ const max extrems :: Fold PixelRGBF (PixelRGBF, PixelRGBF) extrems = (,) <$> minimal <*> maximal volAndDims :: Fold PixelRGBF (Float, PixelRGBF) volAndDims = deltify <$> extrems where deltify (mini, maxi) = (dr * dg * db, delta) where delta@(PixelRGBF dr dg db) = mixWith (const (-)) maxi mini unpackFold :: Fold PixelRGBF a -> Fold PackedRGB a unpackFold (Fold step start done) = Fold (\acc -> step acc . transform) start done where transform = fromRGB8 . rgbIntUnpack mkCluster :: VU.Vector PackedRGB -> Cluster mkCluster ps = Cluster { value = v * fromIntegral l , meanColor = m , dims = ds , colors = ps } where worker = (,,) <$> volAndDims <*> meanRGB <*> intLength ((v, ds), m, l) = fold (unpackFold worker) ps maxAxis :: PixelRGBF -> Axis maxAxis (PixelRGBF r g b) = case (r `compare` g, r `compare` b, g `compare` b) of (GT, GT, _) -> RAxis (LT, GT, _) -> GAxis (GT, LT, _) -> BAxis (LT, LT, GT) -> GAxis (EQ, GT, _) -> RAxis (_, _, _) -> BAxis -- Split a cluster about its largest axis using the mean to divide up the -- pixels. subdivide :: Cluster -> (Cluster, Cluster) subdivide cluster = (mkCluster px1, mkCluster px2) where (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 rgbIntPack :: PixelRGB8 -> PackedRGB rgbIntPack (PixelRGB8 r g b) = wr `unsafeShiftL` (2 * 8) .|. wg `unsafeShiftL` 8 .|. wb where wr = fromIntegral r wg = fromIntegral g wb = fromIntegral b rgbIntUnpack :: PackedRGB -> PixelRGB8 rgbIntUnpack v = PixelRGB8 r g b where r = fromIntegral $ v `unsafeShiftR` (2 * 8) g = fromIntegral $ v `unsafeShiftR` 8 b = fromIntegral v initCluster :: Image PixelRGB8 -> Cluster initCluster img = mkCluster $ VU.generate ((w * h) `div` subSampling) packer where samplingFactor = 3 subSampling = samplingFactor * samplingFactor compCount = componentCount (undefined :: PixelRGB8) w = imageWidth img h = imageHeight img rawData = imageData img packer ix = rgbIntPack . unsafePixelAt rawData $ ix * subSampling * compCount -- Take the cluster with the largest value = (volume * population) and remove it -- from the priority queue. Then subdivide it about its largest axis and put the -- two new clusters on the queue. split :: Set Cluster -> Set Cluster split cs = Set.insert c1 . Set.insert c2 $ cs' where (c, cs') = Set.deleteFindMax cs (c1, c2) = subdivide c -- Keep splitting the initial cluster until there are 256 clusters, then return -- a priority queue containing all 256. clusters :: Int -> Image PixelRGB8 -> Set Cluster clusters maxCols img = clusters' (maxCols - 1) where clusters' :: Int -> Set Cluster clusters' 0 = Set.singleton c clusters' n = split (clusters' (n-1)) c = initCluster img -- Euclidean distance squared, between two pixels. dist2Px :: PixelRGB8 -> PixelRGB8 -> Int dist2Px (PixelRGB8 r1 g1 b1) (PixelRGB8 r2 g2 b2) = dr*dr + dg*dg + db*db where (dr, dg, db) = ( fromIntegral r1 - fromIntegral r2 , fromIntegral g1 - fromIntegral g2 , fromIntegral b1 - fromIntegral b2 ) nearestColorIdx :: PixelRGB8 -> Vector PixelRGB8 -> Pixel8 nearestColorIdx p ps = fromIntegral $ V.minIndex (V.map (`dist2Px` p) ps) JuicyPixels-3.2.8/src/Codec/Picture/Jpg/DefaultTable.hs0000644000000000000000000002557212763010461021024 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -- | Module used by the jpeg decoder internally, shouldn't be used -- in user code. module Codec.Picture.Jpg.DefaultTable( DctComponent( .. ) , HuffmanTree( .. ) , HuffmanTable , HuffmanPackedTree , MacroBlock , QuantificationTable , HuffmanWriterCode , scaleQuantisationMatrix , makeMacroBlock , makeInverseTable , buildHuffmanTree , packHuffmanTree , huffmanPackedDecode , defaultChromaQuantizationTable , defaultLumaQuantizationTable , defaultAcChromaHuffmanTree , defaultAcChromaHuffmanTable , defaultAcLumaHuffmanTree , defaultAcLumaHuffmanTable , defaultDcChromaHuffmanTree , defaultDcChromaHuffmanTable , defaultDcLumaHuffmanTree , defaultDcLumaHuffmanTable ) where import Data.Int( Int16 ) import Foreign.Storable ( Storable ) import Control.Monad.ST( runST ) import qualified Data.Vector.Storable as SV import qualified Data.Vector as V import Data.Bits( unsafeShiftL, (.|.), (.&.) ) import Data.Word( Word8, Word16 ) import Data.List( foldl' ) import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.BitWriter -- | Tree storing the code used for huffman encoding. data HuffmanTree = Branch HuffmanTree HuffmanTree -- ^ If bit is 0 take the first subtree, if 1, the right. | Leaf Word8 -- ^ We should output the value | Empty -- ^ no value present deriving (Eq, Show) type HuffmanPackedTree = SV.Vector Word16 type HuffmanWriterCode = V.Vector (Word8, Word16) packHuffmanTree :: HuffmanTree -> HuffmanPackedTree packHuffmanTree tree = runST $ do table <- M.replicate 512 0x8000 let aux (Empty) idx = return $ idx + 1 aux (Leaf v) idx = do (table `M.unsafeWrite` idx) $ fromIntegral v .|. 0x4000 return $ idx + 1 aux (Branch i1@(Leaf _) i2@(Leaf _)) idx = aux i1 idx >>= aux i2 aux (Branch i1@(Leaf _) i2) idx = do _ <- aux i1 idx ix2 <- aux i2 $ idx + 2 (table `M.unsafeWrite` (idx + 1)) $ fromIntegral $ idx + 2 return ix2 aux (Branch i1 i2@(Leaf _)) idx = do ix1 <- aux i1 (idx + 2) _ <- aux i2 (idx + 1) (table `M.unsafeWrite` idx) . fromIntegral $ idx + 2 return ix1 aux (Branch i1 i2) idx = do ix1 <- aux i1 (idx + 2) ix2 <- aux i2 ix1 (table `M.unsafeWrite` idx) (fromIntegral $ idx + 2) (table `M.unsafeWrite` (idx + 1)) (fromIntegral ix1) return ix2 _ <- aux tree 0 SV.unsafeFreeze table makeInverseTable :: HuffmanTree -> HuffmanWriterCode makeInverseTable t = V.replicate 255 (0,0) V.// inner 0 0 t where inner _ _ Empty = [] inner depth code (Leaf v) = [(fromIntegral v, (depth, code))] inner depth code (Branch l r) = inner (depth + 1) shifted l ++ inner (depth + 1) (shifted .|. 1) r where shifted = code `unsafeShiftL` 1 -- | Represent a compact array of 8 * 8 values. The size -- is not guarenteed by type system, but if makeMacroBlock is -- used, everything should be fine size-wise type MacroBlock a = SV.Vector a type QuantificationTable = MacroBlock Int16 -- | Helper function to create pure macro block of the good size. makeMacroBlock :: (Storable a) => [a] -> MacroBlock a makeMacroBlock = SV.fromListN 64 -- | Enumeration used to search in the tables for different components. data DctComponent = DcComponent | AcComponent deriving (Eq, Show) -- | Transform parsed coefficients from the jpeg header to a -- tree which can be used to decode data. buildHuffmanTree :: [[Word8]] -> HuffmanTree buildHuffmanTree table = foldl' insertHuffmanVal Empty . concatMap (\(i, t) -> map (i + 1,) t) $ zip ([0..] :: [Int]) table where isTreeFullyDefined Empty = False isTreeFullyDefined (Leaf _) = True isTreeFullyDefined (Branch l r) = isTreeFullyDefined l && isTreeFullyDefined r insertHuffmanVal Empty (0, val) = Leaf val insertHuffmanVal Empty (d, val) = Branch (insertHuffmanVal Empty (d - 1, val)) Empty insertHuffmanVal (Branch l r) (d, val) | isTreeFullyDefined l = Branch l (insertHuffmanVal r (d - 1, val)) | otherwise = Branch (insertHuffmanVal l (d - 1, val)) r insertHuffmanVal (Leaf _) _ = error "Inserting in value, shouldn't happen" scaleQuantisationMatrix :: Int -> QuantificationTable -> QuantificationTable scaleQuantisationMatrix quality | quality < 0 = scaleQuantisationMatrix 0 -- shouldn't show much difference than with 1, -- but hey, at least we're complete | quality == 0 = SV.map (scale (10000 :: Int)) | quality < 50 = let qq = 5000 `div` quality in SV.map (scale qq) | otherwise = SV.map (scale q) where q = 200 - quality * 2 scale coeff i = fromIntegral . min 255 . max 1 $ fromIntegral i * coeff `div` 100 huffmanPackedDecode :: HuffmanPackedTree -> BoolReader s Word8 huffmanPackedDecode table = getNextBitJpg >>= aux 0 where aux idx b | (v .&. 0x8000) /= 0 = return 0 | (v .&. 0x4000) /= 0 = return . fromIntegral $ v .&. 0xFF | otherwise = getNextBitJpg >>= aux v where tableIndex | b = idx + 1 | otherwise = idx v = table `SV.unsafeIndex` fromIntegral tableIndex defaultLumaQuantizationTable :: QuantificationTable defaultLumaQuantizationTable = makeMacroBlock [16, 11, 10, 16, 24, 40, 51, 61 ,12, 12, 14, 19, 26, 58, 60, 55 ,14, 13, 16, 24, 40, 57, 69, 56 ,14, 17, 22, 29, 51, 87, 80, 62 ,18, 22, 37, 56, 68, 109, 103, 77 ,24, 35, 55, 64, 81, 104, 113, 92 ,49, 64, 78, 87, 103, 121, 120, 101 ,72, 92, 95, 98, 112, 100, 103, 99 ] defaultChromaQuantizationTable :: QuantificationTable defaultChromaQuantizationTable = makeMacroBlock [17, 18, 24, 47, 99, 99, 99, 99 ,18, 21, 26, 66, 99, 99, 99, 99 ,24, 26, 56, 99, 99, 99, 99, 99 ,47, 66, 99, 99, 99, 99, 99, 99 ,99, 99, 99, 99, 99, 99, 99, 99 ,99, 99, 99, 99, 99, 99, 99, 99 ,99, 99, 99, 99, 99, 99, 99, 99 ,99, 99, 99, 99, 99, 99, 99, 99 ] defaultDcLumaHuffmanTree :: HuffmanTree defaultDcLumaHuffmanTree = buildHuffmanTree defaultDcLumaHuffmanTable -- | From the Table K.3 of ITU-81 (p153) defaultDcLumaHuffmanTable :: HuffmanTable defaultDcLumaHuffmanTable = [ [] , [0] , [1, 2, 3, 4, 5] , [6] , [7] , [8] , [9] , [10] , [11] , [] , [] , [] , [] , [] , [] , [] ] defaultDcChromaHuffmanTree :: HuffmanTree defaultDcChromaHuffmanTree = buildHuffmanTree defaultDcChromaHuffmanTable -- | From the Table K.4 of ITU-81 (p153) defaultDcChromaHuffmanTable :: HuffmanTable defaultDcChromaHuffmanTable = [ [] , [0, 1, 2] , [3] , [4] , [5] , [6] , [7] , [8] , [9] , [10] , [11] , [] , [] , [] , [] , [] ] defaultAcLumaHuffmanTree :: HuffmanTree defaultAcLumaHuffmanTree = buildHuffmanTree defaultAcLumaHuffmanTable -- | From the Table K.5 of ITU-81 (p154) defaultAcLumaHuffmanTable :: HuffmanTable defaultAcLumaHuffmanTable = [ [] , [0x01, 0x02] , [0x03] , [0x00, 0x04, 0x11] , [0x05, 0x12, 0x21] , [0x31, 0x41] , [0x06, 0x13, 0x51, 0x61] , [0x07, 0x22, 0x71] , [0x14, 0x32, 0x81, 0x91, 0xA1] , [0x08, 0x23, 0x42, 0xB1, 0xC1] , [0x15, 0x52, 0xD1, 0xF0] , [0x24, 0x33, 0x62, 0x72] , [] , [] , [0x82] , [0x09, 0x0A, 0x16, 0x17, 0x18, 0x19, 0x1A, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x34, 0x35 ,0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47, 0x48, 0x49, 0x4A, 0x53, 0x54 ,0x55, 0x56, 0x57, 0x58, 0x59, 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 ,0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x83, 0x84, 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A ,0x92, 0x93, 0x94, 0x95, 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6, 0xA7 ,0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7, 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4 ,0xC5, 0xC6, 0xC7, 0xC8, 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9, 0xDA ,0xE1, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA, 0xF1, 0xF2, 0xF3, 0xF4, 0xF5 ,0xF6, 0xF7, 0xF8, 0xF9, 0xFA] ] type HuffmanTable = [[Word8]] defaultAcChromaHuffmanTree :: HuffmanTree defaultAcChromaHuffmanTree = buildHuffmanTree defaultAcChromaHuffmanTable defaultAcChromaHuffmanTable :: HuffmanTable defaultAcChromaHuffmanTable = [ [] , [0x00, 0x01] , [0x02] , [0x03, 0x11] , [0x04, 0x05, 0x21, 0x31] , [0x06, 0x12, 0x41, 0x51] , [0x07, 0x61, 0x71] , [0x13, 0x22, 0x32, 0x81] , [0x08, 0x14, 0x42, 0x91, 0xA1, 0xB1, 0xC1] , [0x09, 0x23, 0x33, 0x52, 0xF0] , [0x15, 0x62, 0x72, 0xD1] , [0x0A, 0x16, 0x24, 0x34] , [] , [0xE1] , [0x25, 0xF1] , [ 0x17, 0x18, 0x19, 0x1A, 0x26, 0x27, 0x28, 0x29, 0x2A, 0x35 , 0x36, 0x37, 0x38, 0x39, 0x3A, 0x43, 0x44, 0x45, 0x46, 0x47 , 0x48, 0x49, 0x4A, 0x53, 0x54, 0x55, 0x56, 0x57, 0x58, 0x59 , 0x5A, 0x63, 0x64, 0x65, 0x66, 0x67, 0x68, 0x69, 0x6A, 0x73 , 0x74, 0x75, 0x76, 0x77, 0x78, 0x79, 0x7A, 0x82, 0x83, 0x84 , 0x85, 0x86, 0x87, 0x88, 0x89, 0x8A, 0x92, 0x93, 0x94, 0x95 , 0x96, 0x97, 0x98, 0x99, 0x9A, 0xA2, 0xA3, 0xA4, 0xA5, 0xA6 , 0xA7, 0xA8, 0xA9, 0xAA, 0xB2, 0xB3, 0xB4, 0xB5, 0xB6, 0xB7 , 0xB8, 0xB9, 0xBA, 0xC2, 0xC3, 0xC4, 0xC5, 0xC6, 0xC7, 0xC8 , 0xC9, 0xCA, 0xD2, 0xD3, 0xD4, 0xD5, 0xD6, 0xD7, 0xD8, 0xD9 , 0xDA, 0xE2, 0xE3, 0xE4, 0xE5, 0xE6, 0xE7, 0xE8, 0xE9, 0xEA , 0xF2, 0xF3, 0xF4, 0xF5, 0xF6, 0xF7, 0xF8, 0xF9, 0xFA ] ] JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Metadata.hs0000644000000000000000000000236612763010461020204 0ustar0000000000000000{-# LANGUAGE CPP #-} module Codec.Picture.Jpg.Metadata ( extractMetadatas, encodeMetadatas ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure ) import Data.Monoid( mempty ) import Data.Word( Word ) #endif import Data.Word( Word16 ) import Data.Maybe( fromMaybe ) import qualified Codec.Picture.Metadata as Met import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.Jpg.Types scalerOfUnit :: JFifUnit -> Met.Keys Word -> Word16 -> Metadatas -> Metadatas scalerOfUnit unit k v = case unit of JFifUnitUnknown -> id JFifPixelsPerInch -> Met.insert k (fromIntegral v) JFifPixelsPerCentimeter -> Met.insert k (Met.dotsPerCentiMeterToDotPerInch $ fromIntegral v) extractMetadatas :: JpgJFIFApp0 -> Metadatas extractMetadatas jfif = inserter Met.DpiX (_jfifDpiX jfif) $ inserter Met.DpiY (_jfifDpiY jfif) mempty where inserter = scalerOfUnit $ _jfifUnit jfif encodeMetadatas :: Metadatas -> [JpgFrame] encodeMetadatas metas = fromMaybe [] $ do dpiX <- Met.lookup Met.DpiX metas dpiY <- Met.lookup Met.DpiY metas pure . pure . JpgJFIF $ JpgJFIFApp0 { _jfifUnit = JFifPixelsPerInch , _jfifDpiX = fromIntegral dpiX , _jfifDpiY = fromIntegral dpiY , _jfifThumbnail = Nothing } JuicyPixels-3.2.8/src/Codec/Picture/Jpg/FastIdct.hs0000644000000000000000000002317312763010461020164 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} -- | Module providing a 'fast' implementation of IDCT -- -- inverse two dimensional DCT, Chen-Wang algorithm -- (cf. IEEE ASSP-32, pp. 803-816, Aug. 1984) -- 32-bit integer arithmetic (8 bit coefficients) -- 11 mults, 29 adds per DCT -- sE, 18.8.91 -- -- coefficients extended to 12 bit for IEEE1180-1990 -- compliance sE, 2.1.94 -- -- this code assumes >> to be a two's-complement arithmetic -- right shift: (-2)>>1 == -1 , (-3)>>1 == -2 module Codec.Picture.Jpg.FastIdct( MutableMacroBlock , fastIdct , mutableLevelShift , createEmptyMutableMacroBlock ) where import qualified Data.Vector.Storable as V import Control.Monad.ST( ST ) import Data.Bits( unsafeShiftL, unsafeShiftR ) import Data.Int( Int16 ) import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.Jpg.Types iclip :: V.Vector Int16 iclip = V.fromListN 1024 [ val i| i <- [(-512) .. 511] ] where val i | i < (-256) = -256 | i > 255 = 255 | otherwise = i data IDctStage = IDctStage { x0 :: {-# UNPACK #-} !Int, x1 :: {-# UNPACK #-} !Int, x2 :: {-# UNPACK #-} !Int, x3 :: {-# UNPACK #-} !Int, x4 :: {-# UNPACK #-} !Int, x5 :: {-# UNPACK #-} !Int, x6 :: {-# UNPACK #-} !Int, x7 :: {-# UNPACK #-} !Int, x8 :: {-# UNPACK #-} !Int } w1, w2, w3, w5, w6, w7 :: Int w1 = 2841 -- 2048*sqrt(2)*cos(1*pi/16) w2 = 2676 -- 2048*sqrt(2)*cos(2*pi/16) w3 = 2408 -- 2048*sqrt(2)*cos(3*pi/16) w5 = 1609 -- 2048*sqrt(2)*cos(5*pi/16) w6 = 1108 -- 2048*sqrt(2)*cos(6*pi/16) w7 = 565 -- 2048*sqrt(2)*cos(7*pi/16) -- row (horizontal) IDCT -- -- 7 pi 1 -- dst[k] = sum c[l] * src[l] * cos( -- * ( k + - ) * l ) -- l=0 8 2 -- -- where: c[0] = 128 -- c[1..7] = 128*sqrt(2) idctRow :: MutableMacroBlock s Int16 -> Int -> ST s () idctRow blk idx = do xx0 <- blk `M.unsafeRead` (0 + idx) xx1 <- blk `M.unsafeRead` (4 + idx) xx2 <- blk `M.unsafeRead` (6 + idx) xx3 <- blk `M.unsafeRead` (2 + idx) xx4 <- blk `M.unsafeRead` (1 + idx) xx5 <- blk `M.unsafeRead` (7 + idx) xx6 <- blk `M.unsafeRead` (5 + idx) xx7 <- blk `M.unsafeRead` (3 + idx) let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 11) + 128 , x1 = fromIntegral xx1 `unsafeShiftL` 11 , x2 = fromIntegral xx2 , x3 = fromIntegral xx3 , x4 = fromIntegral xx4 , x5 = fromIntegral xx5 , x6 = fromIntegral xx6 , x7 = fromIntegral xx7 , x8 = 0 } firstStage c = c { x4 = x8' + (w1 - w7) * x4 c , x5 = x8' - (w1 + w7) * x5 c , x6 = x8'' - (w3 - w5) * x6 c , x7 = x8'' - (w3 + w5) * x7 c , x8 = x8'' } where x8' = w7 * (x4 c + x5 c) x8'' = w3 * (x6 c + x7 c) secondStage c = c { x0 = x0 c - x1 c , x8 = x0 c + x1 c , x1 = x1'' , x2 = x1' - (w2 + w6) * x2 c , x3 = x1' + (w2 - w6) * x3 c , x4 = x4 c - x6 c , x6 = x5 c + x7 c , x5 = x5 c - x7 c } where x1' = w6 * (x3 c + x2 c) x1'' = x4 c + x6 c thirdStage c = c { x7 = x8 c + x3 c , x8 = x8 c - x3 c , x3 = x0 c + x2 c , x0 = x0 c - x2 c , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 } scaled c = c { x0 = (x7 c + x1 c) `unsafeShiftR` 8 , x1 = (x3 c + x2 c) `unsafeShiftR` 8 , x2 = (x0 c + x4 c) `unsafeShiftR` 8 , x3 = (x8 c + x6 c) `unsafeShiftR` 8 , x4 = (x8 c - x6 c) `unsafeShiftR` 8 , x5 = (x0 c - x4 c) `unsafeShiftR` 8 , x6 = (x3 c - x2 c) `unsafeShiftR` 8 , x7 = (x7 c - x1 c) `unsafeShiftR` 8 } transformed = scaled . thirdStage . secondStage $ firstStage initialState (blk `M.unsafeWrite` (0 + idx)) . fromIntegral $ x0 transformed (blk `M.unsafeWrite` (1 + idx)) . fromIntegral $ x1 transformed (blk `M.unsafeWrite` (2 + idx)) . fromIntegral $ x2 transformed (blk `M.unsafeWrite` (3 + idx)) . fromIntegral $ x3 transformed (blk `M.unsafeWrite` (4 + idx)) . fromIntegral $ x4 transformed (blk `M.unsafeWrite` (5 + idx)) . fromIntegral $ x5 transformed (blk `M.unsafeWrite` (6 + idx)) . fromIntegral $ x6 transformed (blk `M.unsafeWrite` (7 + idx)) . fromIntegral $ x7 transformed -- column (vertical) IDCT -- -- 7 pi 1 -- dst[8*k] = sum c[l] * src[8*l] * cos( -- * ( k + - ) * l ) -- l=0 8 2 -- -- where: c[0] = 1/1024 -- c[1..7] = (1/1024)*sqrt(2) -- idctCol :: MutableMacroBlock s Int16 -> Int -> ST s () idctCol blk idx = do xx0 <- blk `M.unsafeRead` ( 0 + idx) xx1 <- blk `M.unsafeRead` (8 * 4 + idx) xx2 <- blk `M.unsafeRead` (8 * 6 + idx) xx3 <- blk `M.unsafeRead` (8 * 2 + idx) xx4 <- blk `M.unsafeRead` (8 + idx) xx5 <- blk `M.unsafeRead` (8 * 7 + idx) xx6 <- blk `M.unsafeRead` (8 * 5 + idx) xx7 <- blk `M.unsafeRead` (8 * 3 + idx) let initialState = IDctStage { x0 = (fromIntegral xx0 `unsafeShiftL` 8) + 8192 , x1 = fromIntegral xx1 `unsafeShiftL` 8 , x2 = fromIntegral xx2 , x3 = fromIntegral xx3 , x4 = fromIntegral xx4 , x5 = fromIntegral xx5 , x6 = fromIntegral xx6 , x7 = fromIntegral xx7 , x8 = 0 } firstStage c = c { x4 = (x8' + (w1 - w7) * x4 c) `unsafeShiftR` 3 , x5 = (x8' - (w1 + w7) * x5 c) `unsafeShiftR` 3 , x6 = (x8'' - (w3 - w5) * x6 c) `unsafeShiftR` 3 , x7 = (x8'' - (w3 + w5) * x7 c) `unsafeShiftR` 3 , x8 = x8'' } where x8' = w7 * (x4 c + x5 c) + 4 x8'' = w3 * (x6 c + x7 c) + 4 secondStage c = c { x8 = x0 c + x1 c , x0 = x0 c - x1 c , x2 = (x1' - (w2 + w6) * x2 c) `unsafeShiftR` 3 , x3 = (x1' + (w2 - w6) * x3 c) `unsafeShiftR` 3 , x4 = x4 c - x6 c , x1 = x1'' , x6 = x5 c + x7 c , x5 = x5 c - x7 c } where x1' = w6 * (x3 c + x2 c) + 4 x1'' = x4 c + x6 c thirdStage c = c { x7 = x8 c + x3 c , x8 = x8 c - x3 c , x3 = x0 c + x2 c , x0 = x0 c - x2 c , x2 = (181 * (x4 c + x5 c) + 128) `unsafeShiftR` 8 , x4 = (181 * (x4 c - x5 c) + 128) `unsafeShiftR` 8 } clip i | i < 511 = if i > -512 then iclip `V.unsafeIndex` (i + 512) else iclip `V.unsafeIndex` 0 | otherwise = iclip `V.unsafeIndex` 1023 f = thirdStage . secondStage $ firstStage initialState (blk `M.unsafeWrite` (idx + 8*0)) . clip $ (x7 f + x1 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8 )) . clip $ (x3 f + x2 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*2)) . clip $ (x0 f + x4 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*3)) . clip $ (x8 f + x6 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*4)) . clip $ (x8 f - x6 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*5)) . clip $ (x0 f - x4 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*6)) . clip $ (x3 f - x2 f) `unsafeShiftR` 14 (blk `M.unsafeWrite` (idx + 8*7)) . clip $ (x7 f - x1 f) `unsafeShiftR` 14 {-# INLINE fastIdct #-} -- | Algorithm to call to perform an IDCT, return the same -- block that the one given as input. fastIdct :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) fastIdct block = rows 0 where rows 8 = cols 0 rows i = idctRow block (8 * i) >> rows (i + 1) cols 8 = return block cols i = idctCol block i >> cols (i + 1) {-# INLINE mutableLevelShift #-} -- | Perform a Jpeg level shift in a mutable fashion. mutableLevelShift :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) mutableLevelShift block = update 0 where update 64 = return block update idx = do val <- block `M.unsafeRead` idx (block `M.unsafeWrite` idx) $ val + 128 update $ idx + 1 JuicyPixels-3.2.8/src/Codec/Picture/Jpg/FastDct.hs0000644000000000000000000002063712763010461020015 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} module Codec.Picture.Jpg.FastDct( referenceDct, fastDctLibJpeg ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) #endif import Data.Int( Int16, Int32 ) import Data.Bits( unsafeShiftR, unsafeShiftL ) import Control.Monad.ST( ST ) import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.Jpg.Types import Control.Monad( forM, forM_ ) -- | Reference implementation of the DCT, directly implementing the formula -- of ITU-81. It's slow as hell, perform to many operations, but is accurate -- and a good reference point. referenceDct :: MutableMacroBlock s Int32 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32) referenceDct workData block = do forM_ [(u, v) | u <- [0 :: Int .. dctBlockSize - 1], v <- [0..dctBlockSize - 1]] $ \(u,v) -> do val <- at (u,v) (workData `M.unsafeWrite` (v * dctBlockSize + u)) . truncate $ (1 / 4) * c u * c v * val return workData where -- at :: (Int, Int) -> ST s Float at (u,v) = do toSum <- forM [(x,y) | x <- [0..dctBlockSize - 1], y <- [0..dctBlockSize - 1 :: Int]] $ \(x,y) -> do sample <- fromIntegral <$> (block `M.unsafeRead` (y * dctBlockSize + x)) return $ sample * cos ((2 * fromIntegral x + 1) * fromIntegral u * (pi :: Float)/ 16) * cos ((2 * fromIntegral y + 1) * fromIntegral v * pi / 16) return $ sum toSum c 0 = 1 / sqrt 2 c _ = 1 pASS1_BITS, cONST_BITS :: Int cONST_BITS = 13 pASS1_BITS = 2 fIX_0_298631336, fIX_0_390180644, fIX_0_541196100, fIX_0_765366865, fIX_0_899976223, fIX_1_175875602, fIX_1_501321110, fIX_1_847759065, fIX_1_961570560, fIX_2_053119869, fIX_2_562915447, fIX_3_072711026 :: Int32 fIX_0_298631336 = 2446 -- FIX(0.298631336) */ fIX_0_390180644 = 3196 -- FIX(0.390180644) */ fIX_0_541196100 = 4433 -- FIX(0.541196100) */ fIX_0_765366865 = 6270 -- FIX(0.765366865) */ fIX_0_899976223 = 7373 -- FIX(0.899976223) */ fIX_1_175875602 = 9633 -- FIX(1.175875602) */ fIX_1_501321110 = 12299 -- FIX(1.501321110) */ fIX_1_847759065 = 15137 -- FIX(1.847759065) */ fIX_1_961570560 = 16069 -- FIX(1.961570560) */ fIX_2_053119869 = 16819 -- FIX(2.053119869) */ fIX_2_562915447 = 20995 -- FIX(2.562915447) */ fIX_3_072711026 = 25172 -- FIX(3.072711026) */ cENTERJSAMPLE :: Int32 cENTERJSAMPLE = 128 -- | Fast DCT extracted from libjpeg fastDctLibJpeg :: MutableMacroBlock s Int32 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int32) fastDctLibJpeg workData sample_block = do firstPass workData 0 secondPass workData 7 {-_ <- mutate (\_ a -> a `quot` 8) workData-} return workData where -- Pass 1: process rows. -- Note results are scaled up by sqrt(8) compared to a true DCT; -- furthermore, we scale the results by 2**PASS1_BITS. firstPass _ i | i == dctBlockSize = return () firstPass dataBlock i = do let baseIdx = i * dctBlockSize readAt idx = fromIntegral <$> sample_block `M.unsafeRead` (baseIdx + idx) mult = (*) writeAt idx = dataBlock `M.unsafeWrite` (baseIdx + idx) writeAtPos idx n = (dataBlock `M.unsafeWrite` (baseIdx + idx)) (n `unsafeShiftR` (cONST_BITS - pASS1_BITS)) blk0 <- readAt 0 blk1 <- readAt 1 blk2 <- readAt 2 blk3 <- readAt 3 blk4 <- readAt 4 blk5 <- readAt 5 blk6 <- readAt 6 blk7 <- readAt 7 let tmp0 = blk0 + blk7 tmp1 = blk1 + blk6 tmp2 = blk2 + blk5 tmp3 = blk3 + blk4 tmp10 = tmp0 + tmp3 tmp12 = tmp0 - tmp3 tmp11 = tmp1 + tmp2 tmp13 = tmp1 - tmp2 tmp0' = blk0 - blk7 tmp1' = blk1 - blk6 tmp2' = blk2 - blk5 tmp3' = blk3 - blk4 -- Stage 4 and output writeAt 0 $ (tmp10 + tmp11 - dctBlockSize * cENTERJSAMPLE) `unsafeShiftL` pASS1_BITS writeAt 4 $ (tmp10 - tmp11) `unsafeShiftL` pASS1_BITS let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS - 1)) writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 let tmp10' = tmp0' + tmp3' tmp11' = tmp1' + tmp2' tmp12' = tmp0' + tmp2' tmp13' = tmp1' + tmp3' z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- c3 */ -- Add fudge factor here for final descale. */ + (1 `unsafeShiftL` (cONST_BITS - pASS1_BITS-1)) tmp0'' = mult tmp0' fIX_1_501321110 tmp1'' = mult tmp1' fIX_3_072711026 tmp2'' = mult tmp2' fIX_2_053119869 tmp3'' = mult tmp3' fIX_0_298631336 tmp10'' = mult tmp10' (- fIX_0_899976223) tmp11'' = mult tmp11' (- fIX_2_562915447) tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' firstPass dataBlock $ i + 1 -- Pass 2: process columns. -- We remove the PASS1_BITS scaling, but leave the results scaled up -- by an overall factor of 8. secondPass :: M.STVector s Int32 -> Int -> ST s () secondPass _ (-1) = return () secondPass block i = do let readAt idx = block `M.unsafeRead` ((7 - i) + idx * dctBlockSize) mult = (*) writeAt idx = block `M.unsafeWrite` (dctBlockSize * idx + (7 - i)) writeAtPos idx n = (block `M.unsafeWrite` (dctBlockSize * idx + (7 - i))) $ n `unsafeShiftR` (cONST_BITS + pASS1_BITS + 3) blk0 <- readAt 0 blk1 <- readAt 1 blk2 <- readAt 2 blk3 <- readAt 3 blk4 <- readAt 4 blk5 <- readAt 5 blk6 <- readAt 6 blk7 <- readAt 7 let tmp0 = blk0 + blk7 tmp1 = blk1 + blk6 tmp2 = blk2 + blk5 tmp3 = blk3 + blk4 -- Add fudge factor here for final descale. */ tmp10 = tmp0 + tmp3 + (1 `unsafeShiftL` (pASS1_BITS-1)) tmp12 = tmp0 - tmp3 tmp11 = tmp1 + tmp2 tmp13 = tmp1 - tmp2 tmp0' = blk0 - blk7 tmp1' = blk1 - blk6 tmp2' = blk2 - blk5 tmp3' = blk3 - blk4 writeAt 0 $ (tmp10 + tmp11) `unsafeShiftR` (pASS1_BITS + 3) writeAt 4 $ (tmp10 - tmp11) `unsafeShiftR` (pASS1_BITS + 3) let z1 = mult (tmp12 + tmp13) fIX_0_541196100 + (1 `unsafeShiftL` (cONST_BITS + pASS1_BITS - 1)) writeAtPos 2 $ z1 + mult tmp12 fIX_0_765366865 writeAtPos 6 $ z1 - mult tmp13 fIX_1_847759065 let tmp10' = tmp0' + tmp3' tmp11' = tmp1' + tmp2' tmp12' = tmp0' + tmp2' tmp13' = tmp1' + tmp3' z1' = mult (tmp12' + tmp13') fIX_1_175875602 -- Add fudge factor here for final descale. */ + 1 `unsafeShiftL` (cONST_BITS+pASS1_BITS-1); tmp0'' = mult tmp0' fIX_1_501321110 tmp1'' = mult tmp1' fIX_3_072711026 tmp2'' = mult tmp2' fIX_2_053119869 tmp3'' = mult tmp3' fIX_0_298631336 tmp10'' = mult tmp10' (- fIX_0_899976223) tmp11'' = mult tmp11' (- fIX_2_562915447) tmp12'' = mult tmp12' (- fIX_0_390180644) + z1' tmp13'' = mult tmp13' (- fIX_1_961570560) + z1' writeAtPos 1 $ tmp0'' + tmp10'' + tmp12'' writeAtPos 3 $ tmp1'' + tmp11'' + tmp13'' writeAtPos 5 $ tmp2'' + tmp11'' + tmp12'' writeAtPos 7 $ tmp3'' + tmp10'' + tmp13'' secondPass block (i - 1) {-# ANN module "HLint: ignore Use camelCase" #-} {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Types.hs0000644000000000000000000006020512763010461017564 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Codec.Picture.Jpg.Types( MutableMacroBlock , createEmptyMutableMacroBlock , printMacroBlock , printPureMacroBlock , DcCoefficient , JpgImage( .. ) , JpgComponent( .. ) , JpgFrameHeader( .. ) , JpgFrame( .. ) , JpgFrameKind( .. ) , JpgScanHeader( .. ) , JpgQuantTableSpec( .. ) , JpgHuffmanTableSpec( .. ) , JpgImageKind( .. ) , JpgScanSpecification( .. ) , JpgColorSpace( .. ) , AdobeTransform( .. ) , JpgAdobeApp14( .. ) , JpgJFIFApp0( .. ) , JFifUnit( .. ) , calculateSize , dctBlockSize ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<*>), (<$>) ) #endif import Control.Monad( when, replicateM, forM, forM_, unless ) import Control.Monad.ST( ST ) import Data.Bits( (.|.), (.&.), unsafeShiftL, unsafeShiftR ) import Foreign.Storable ( Storable ) import Data.Vector.Unboxed( (!) ) import qualified Data.Vector as V import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L import Data.Int( Int16 ) import Data.Word(Word8, Word16 ) import Data.Binary( Binary(..) ) import Data.Binary.Get( Get , getWord8 , getWord16be , getByteString , skip , bytesRead ) import Data.Binary.Put( Put , putWord8 , putWord16be , putLazyByteString , putByteString ) import Codec.Picture.InternalHelper import Codec.Picture.Jpg.DefaultTable import Codec.Picture.Tiff.Types {-import Debug.Trace-} import Text.Printf -- | Type only used to make clear what kind of integer we are carrying -- Might be transformed into newtype in the future type DcCoefficient = Int16 -- | Macroblock that can be transformed. type MutableMacroBlock s a = M.STVector s a data JpgFrameKind = JpgBaselineDCTHuffman | JpgExtendedSequentialDCTHuffman | JpgProgressiveDCTHuffman | JpgLosslessHuffman | JpgDifferentialSequentialDCTHuffman | JpgDifferentialProgressiveDCTHuffman | JpgDifferentialLosslessHuffman | JpgExtendedSequentialArithmetic | JpgProgressiveDCTArithmetic | JpgLosslessArithmetic | JpgDifferentialSequentialDCTArithmetic | JpgDifferentialProgressiveDCTArithmetic | JpgDifferentialLosslessArithmetic | JpgQuantizationTable | JpgHuffmanTableMarker | JpgStartOfScan | JpgEndOfImage | JpgAppSegment Word8 | JpgExtensionSegment Word8 | JpgRestartInterval | JpgRestartIntervalEnd Word8 deriving (Eq, Show) data JpgFrame = JpgAppFrame !Word8 B.ByteString | JpgAdobeAPP14 !JpgAdobeApp14 | JpgJFIF !JpgJFIFApp0 | JpgExif ![ImageFileDirectory] | JpgExtension !Word8 B.ByteString | JpgQuantTable ![JpgQuantTableSpec] | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] | JpgScanBlob !JpgScanHeader !L.ByteString | JpgScans !JpgFrameKind !JpgFrameHeader | JpgIntervalRestart !Word16 deriving Show data JpgColorSpace = JpgColorSpaceYCbCr | JpgColorSpaceYCC | JpgColorSpaceY | JpgColorSpaceYA | JpgColorSpaceYCCA | JpgColorSpaceYCCK | JpgColorSpaceCMYK | JpgColorSpaceRGB | JpgColorSpaceRGBA deriving Show data AdobeTransform = AdobeUnknown -- ^ Value 0 | AdobeYCbCr -- ^ value 1 | AdobeYCck -- ^ value 2 deriving Show data JpgAdobeApp14 = JpgAdobeApp14 { _adobeDctVersion :: !Word16 , _adobeFlag0 :: !Word16 , _adobeFlag1 :: !Word16 , _adobeTransform :: !AdobeTransform } deriving Show -- | Size: 1 data JFifUnit = JFifUnitUnknown -- ^ 0 | JFifPixelsPerInch -- ^ 1 | JFifPixelsPerCentimeter -- ^ 2 deriving Show instance Binary JFifUnit where put v = putWord8 $ case v of JFifUnitUnknown -> 0 JFifPixelsPerInch -> 1 JFifPixelsPerCentimeter -> 2 get = do v <- getWord8 pure $ case v of 0 -> JFifUnitUnknown 1 -> JFifPixelsPerInch 2 -> JFifPixelsPerCentimeter _ -> JFifUnitUnknown data JpgJFIFApp0 = JpgJFIFApp0 { _jfifUnit :: !JFifUnit , _jfifDpiX :: !Word16 , _jfifDpiY :: !Word16 , _jfifThumbnail :: !(Maybe {- (Image PixelRGB8) -} Int) } deriving Show instance Binary JpgJFIFApp0 where get = do sig <- getByteString 5 when (sig /= BC.pack "JFIF\0") $ fail "Invalid JFIF signature" major <- getWord8 minor <- getWord8 when (major /= 1 && minor > 2) $ fail "Unrecognize JFIF version" unit <- get dpiX <- getWord16be dpiY <- getWord16be w <- getWord8 h <- getWord8 let pxCount = 3 * w * h img <- case pxCount of 0 -> return Nothing _ -> return Nothing return $ JpgJFIFApp0 { _jfifUnit = unit , _jfifDpiX = dpiX , _jfifDpiY = dpiY , _jfifThumbnail = img } put jfif = do putByteString $ BC.pack "JFIF\0" -- 5 putWord8 1 -- 1 6 putWord8 2 -- 1 7 put $ _jfifUnit jfif -- 1 8 putWord16be $ _jfifDpiX jfif -- 2 10 putWord16be $ _jfifDpiY jfif -- 2 12 putWord8 0 -- 1 13 putWord8 0 -- 1 14 {-Thumbnail width (tw) 1 Horizontal size of embedded JFIF thumbnail in pixels-} {-Thumbnail height (th) 1 Vertical size of embedded JFIF thumbnail in pixels-} {-Thumbnail data 3 × tw × th Uncompressed 24 bit RGB raster thumbnail-} instance Binary AdobeTransform where put v = case v of AdobeUnknown -> putWord8 0 AdobeYCbCr -> putWord8 1 AdobeYCck -> putWord8 2 get = do v <- getWord8 pure $ case v of 0 -> AdobeUnknown 1 -> AdobeYCbCr 2 -> AdobeYCck _ -> AdobeUnknown instance Binary JpgAdobeApp14 where get = do let sig = BC.pack "Adobe" fileSig <- getByteString 5 when (fileSig /= sig) $ fail "Invalid Adobe APP14 marker" version <- getWord16be when (version /= 100) $ fail $ "Invalid Adobe APP14 version " ++ show version JpgAdobeApp14 version <$> getWord16be <*> getWord16be <*> get put (JpgAdobeApp14 v f0 f1 t) = do putByteString $ BC.pack "Adobe" putWord16be v putWord16be f0 putWord16be f1 put t data JpgFrameHeader = JpgFrameHeader { jpgFrameHeaderLength :: !Word16 , jpgSamplePrecision :: !Word8 , jpgHeight :: !Word16 , jpgWidth :: !Word16 , jpgImageComponentCount :: !Word8 , jpgComponents :: ![JpgComponent] } deriving Show instance SizeCalculable JpgFrameHeader where calculateSize hdr = 2 + 1 + 2 + 2 + 1 + sum [calculateSize c | c <- jpgComponents hdr] data JpgComponent = JpgComponent { componentIdentifier :: !Word8 -- | Stored with 4 bits , horizontalSamplingFactor :: !Word8 -- | Stored with 4 bits , verticalSamplingFactor :: !Word8 , quantizationTableDest :: !Word8 } deriving Show instance SizeCalculable JpgComponent where calculateSize _ = 3 data JpgImage = JpgImage { jpgFrame :: [JpgFrame] } deriving Show data JpgScanSpecification = JpgScanSpecification { componentSelector :: !Word8 -- | Encoded as 4 bits , dcEntropyCodingTable :: !Word8 -- | Encoded as 4 bits , acEntropyCodingTable :: !Word8 } deriving Show instance SizeCalculable JpgScanSpecification where calculateSize _ = 2 data JpgScanHeader = JpgScanHeader { scanLength :: !Word16 , scanComponentCount :: !Word8 , scans :: [JpgScanSpecification] -- | (begin, end) , spectralSelection :: (Word8, Word8) -- | Encoded as 4 bits , successiveApproxHigh :: !Word8 -- | Encoded as 4 bits , successiveApproxLow :: !Word8 } deriving Show instance SizeCalculable JpgScanHeader where calculateSize hdr = 2 + 1 + sum [calculateSize c | c <- scans hdr] + 2 + 1 data JpgQuantTableSpec = JpgQuantTableSpec { -- | Stored on 4 bits quantPrecision :: !Word8 -- | Stored on 4 bits , quantDestination :: !Word8 , quantTable :: MacroBlock Int16 } deriving Show class SizeCalculable a where calculateSize :: a -> Int -- | Type introduced only to avoid some typeclass overlapping -- problem newtype TableList a = TableList [a] instance (SizeCalculable a, Binary a) => Binary (TableList a) where put (TableList lst) = do putWord16be . fromIntegral $ sum [calculateSize table | table <- lst] + 2 mapM_ put lst get = TableList <$> (getWord16be >>= \s -> innerParse (fromIntegral s - 2)) where innerParse :: Int -> Get [a] innerParse 0 = return [] innerParse size = do onStart <- fromIntegral <$> bytesRead table <- get onEnd <- fromIntegral <$> bytesRead (table :) <$> innerParse (size - (onEnd - onStart)) instance SizeCalculable JpgQuantTableSpec where calculateSize table = 1 + (fromIntegral (quantPrecision table) + 1) * 64 instance Binary JpgQuantTableSpec where put table = do let precision = quantPrecision table put4BitsOfEach precision (quantDestination table) forM_ (VS.toList $ quantTable table) $ \coeff -> if precision == 0 then putWord8 $ fromIntegral coeff else putWord16be $ fromIntegral coeff get = do (precision, dest) <- get4BitOfEach coeffs <- replicateM 64 $ if precision == 0 then fromIntegral <$> getWord8 else fromIntegral <$> getWord16be return JpgQuantTableSpec { quantPrecision = precision , quantDestination = dest , quantTable = VS.fromListN 64 coeffs } data JpgHuffmanTableSpec = JpgHuffmanTableSpec { -- | 0 : DC, 1 : AC, stored on 4 bits huffmanTableClass :: !DctComponent -- | Stored on 4 bits , huffmanTableDest :: !Word8 , huffSizes :: !(VU.Vector Word8) , huffCodes :: !(V.Vector (VU.Vector Word8)) } deriving Show instance SizeCalculable JpgHuffmanTableSpec where calculateSize table = 1 + 16 + sum [fromIntegral e | e <- VU.toList $ huffSizes table] instance Binary JpgHuffmanTableSpec where put table = do let classVal = if huffmanTableClass table == DcComponent then 0 else 1 put4BitsOfEach classVal $ huffmanTableDest table mapM_ put . VU.toList $ huffSizes table forM_ [0 .. 15] $ \i -> when (huffSizes table ! i /= 0) (let elements = VU.toList $ huffCodes table V.! i in mapM_ put elements) get = do (huffClass, huffDest) <- get4BitOfEach sizes <- replicateM 16 getWord8 codes <- forM sizes $ \s -> VU.replicateM (fromIntegral s) getWord8 return JpgHuffmanTableSpec { huffmanTableClass = if huffClass == 0 then DcComponent else AcComponent , huffmanTableDest = huffDest , huffSizes = VU.fromListN 16 sizes , huffCodes = V.fromListN 16 codes } instance Binary JpgImage where put (JpgImage { jpgFrame = frames }) = putWord8 0xFF >> putWord8 0xD8 >> mapM_ putFrame frames >> putWord8 0xFF >> putWord8 0xD9 get = do let startOfImageMarker = 0xD8 -- endOfImageMarker = 0xD9 checkMarker commonMarkerFirstByte startOfImageMarker eatUntilCode frames <- parseFrames {-checkMarker commonMarkerFirstByte endOfImageMarker-} return JpgImage { jpgFrame = frames } eatUntilCode :: Get () eatUntilCode = do code <- getWord8 unless (code == 0xFF) eatUntilCode takeCurrentFrame :: Get B.ByteString takeCurrentFrame = do size <- getWord16be getByteString (fromIntegral size - 2) putFrame :: JpgFrame -> Put putFrame (JpgAdobeAPP14 adobe) = put (JpgAppSegment 14) >> putWord16be 14 >> put adobe putFrame (JpgJFIF jfif) = put (JpgAppSegment 0) >> putWord16be (14+2) >> put jfif putFrame (JpgExif _exif) = return () -- TODO {-put (JpgAppSegment 0) >> put exif-} putFrame (JpgAppFrame appCode str) = put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str putFrame (JpgExtension appCode str) = put (JpgExtensionSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str putFrame (JpgQuantTable tables) = put JpgQuantizationTable >> put (TableList tables) putFrame (JpgHuffmanTable tables) = put JpgHuffmanTableMarker >> put (TableList $ map fst tables) putFrame (JpgIntervalRestart size) = put JpgRestartInterval >> put (RestartInterval size) putFrame (JpgScanBlob hdr blob) = do put JpgStartOfScan put hdr putLazyByteString blob putWord8 0 -- AKA the libjpeg pleaser, for some unknown reason -- libjpeg raise a warning "invalid end of data segment". -- so dumbly pad, seems to make the warning go away (and -- I don't want to invest that much time looking for that). -- -- Ok this is a crummy fix.... putFrame (JpgScans kind hdr) = put kind >> put hdr -------------------------------------------------- ---- Serialization instances -------------------------------------------------- commonMarkerFirstByte :: Word8 commonMarkerFirstByte = 0xFF checkMarker :: Word8 -> Word8 -> Get () checkMarker b1 b2 = do rb1 <- getWord8 rb2 <- getWord8 when (rb1 /= b1 || rb2 /= b2) (fail "Invalid marker used") extractScanContent :: L.ByteString -> (L.ByteString, L.ByteString) extractScanContent str = aux 0 where maxi = fromIntegral $ L.length str - 1 aux n | n >= maxi = (str, L.empty) | v == 0xFF && vNext /= 0 && not isReset = L.splitAt n str | otherwise = aux (n + 1) where v = str `L.index` n vNext = str `L.index` (n + 1) isReset = 0xD0 <= vNext && vNext <= 0xD7 parseAdobe14 :: B.ByteString -> [JpgFrame] -> [JpgFrame] parseAdobe14 str lst = go where go = case runGetStrict get str of Left _err -> lst Right app14 -> JpgAdobeAPP14 app14 : lst -- | Parse JFIF or JFXX information. Right now only JFIF. parseJF__ :: B.ByteString -> [JpgFrame] -> [JpgFrame] parseJF__ str lst = go where go = case runGetStrict get str of Left _err -> lst Right jfif -> JpgJFIF jfif : lst parseExif :: B.ByteString -> [JpgFrame] -> [JpgFrame] parseExif str lst | exifHeader `B.isPrefixOf` str = go | otherwise = lst where exifHeader = BC.pack "Exif\0\0" tiff = B.drop (B.length exifHeader) str go = case runGetStrict (getP tiff) tiff of Left _err -> lst Right (_hdr :: TiffHeader, ifds) -> JpgExif ifds : lst parseFrames :: Get [JpgFrame] parseFrames = do kind <- get let parseNextFrame = do word <- getWord8 when (word /= 0xFF) $ do readedData <- bytesRead fail $ "Invalid Frame marker (" ++ show word ++ ", bytes read : " ++ show readedData ++ ")" parseFrames case kind of JpgEndOfImage -> return [] JpgAppSegment 0 -> parseJF__ <$> takeCurrentFrame <*> parseNextFrame JpgAppSegment 1 -> parseExif <$> takeCurrentFrame <*> parseNextFrame JpgAppSegment 14 -> parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame JpgAppSegment c -> (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgExtensionSegment c -> (\frm lst -> JpgExtension c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgQuantizationTable -> (\(TableList quants) lst -> JpgQuantTable quants : lst) <$> get <*> parseNextFrame JpgRestartInterval -> (\(RestartInterval i) lst -> JpgIntervalRestart i : lst) <$> get <*> parseNextFrame JpgHuffmanTableMarker -> (\(TableList huffTables) lst -> JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) <$> get <*> parseNextFrame JpgStartOfScan -> (\frm imgData -> let (d, other) = extractScanContent imgData in case runGet parseFrames (L.drop 1 other) of Left _ -> [JpgScanBlob frm d] Right lst -> JpgScanBlob frm d : lst ) <$> get <*> getRemainingLazyBytes _ -> (\hdr lst -> JpgScans kind hdr : lst) <$> get <*> parseNextFrame buildPackedHuffmanTree :: V.Vector (VU.Vector Word8) -> HuffmanTree buildPackedHuffmanTree = buildHuffmanTree . map VU.toList . V.toList secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 secondStartOfFrameByteOfKind = aux where aux JpgBaselineDCTHuffman = 0xC0 aux JpgExtendedSequentialDCTHuffman = 0xC1 aux JpgProgressiveDCTHuffman = 0xC2 aux JpgLosslessHuffman = 0xC3 aux JpgDifferentialSequentialDCTHuffman = 0xC5 aux JpgDifferentialProgressiveDCTHuffman = 0xC6 aux JpgDifferentialLosslessHuffman = 0xC7 aux JpgExtendedSequentialArithmetic = 0xC9 aux JpgProgressiveDCTArithmetic = 0xCA aux JpgLosslessArithmetic = 0xCB aux JpgHuffmanTableMarker = 0xC4 aux JpgDifferentialSequentialDCTArithmetic = 0xCD aux JpgDifferentialProgressiveDCTArithmetic = 0xCE aux JpgDifferentialLosslessArithmetic = 0xCF aux JpgEndOfImage = 0xD9 aux JpgQuantizationTable = 0xDB aux JpgStartOfScan = 0xDA aux JpgRestartInterval = 0xDD aux (JpgRestartIntervalEnd v) = v aux (JpgAppSegment a) = (a + 0xE0) aux (JpgExtensionSegment a) = a data JpgImageKind = BaseLineDCT | ProgressiveDCT instance Binary JpgFrameKind where put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) get = do -- no lookahead :( {-word <- getWord8-} word2 <- getWord8 return $ case word2 of 0xC0 -> JpgBaselineDCTHuffman 0xC1 -> JpgExtendedSequentialDCTHuffman 0xC2 -> JpgProgressiveDCTHuffman 0xC3 -> JpgLosslessHuffman 0xC4 -> JpgHuffmanTableMarker 0xC5 -> JpgDifferentialSequentialDCTHuffman 0xC6 -> JpgDifferentialProgressiveDCTHuffman 0xC7 -> JpgDifferentialLosslessHuffman 0xC9 -> JpgExtendedSequentialArithmetic 0xCA -> JpgProgressiveDCTArithmetic 0xCB -> JpgLosslessArithmetic 0xCD -> JpgDifferentialSequentialDCTArithmetic 0xCE -> JpgDifferentialProgressiveDCTArithmetic 0xCF -> JpgDifferentialLosslessArithmetic 0xD9 -> JpgEndOfImage 0xDA -> JpgStartOfScan 0xDB -> JpgQuantizationTable 0xDD -> JpgRestartInterval a | a >= 0xF0 -> JpgExtensionSegment a | a >= 0xE0 -> JpgAppSegment (a - 0xE0) | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") put4BitsOfEach :: Word8 -> Word8 -> Put put4BitsOfEach a b = put $ (a `unsafeShiftL` 4) .|. b get4BitOfEach :: Get (Word8, Word8) get4BitOfEach = do val <- get return ((val `unsafeShiftR` 4) .&. 0xF, val .&. 0xF) newtype RestartInterval = RestartInterval Word16 instance Binary RestartInterval where put (RestartInterval i) = putWord16be 4 >> putWord16be i get = do size <- getWord16be when (size /= 4) (fail "Invalid jpeg restart interval size") RestartInterval <$> getWord16be instance Binary JpgComponent where get = do ident <- getWord8 (horiz, vert) <- get4BitOfEach quantTableIndex <- getWord8 return JpgComponent { componentIdentifier = ident , horizontalSamplingFactor = horiz , verticalSamplingFactor = vert , quantizationTableDest = quantTableIndex } put v = do put $ componentIdentifier v put4BitsOfEach (horizontalSamplingFactor v) $ verticalSamplingFactor v put $ quantizationTableDest v instance Binary JpgFrameHeader where get = do beginOffset <- fromIntegral <$> bytesRead frmHLength <- getWord16be samplePrec <- getWord8 h <- getWord16be w <- getWord16be compCount <- getWord8 components <- replicateM (fromIntegral compCount) get endOffset <- fromIntegral <$> bytesRead when (beginOffset - endOffset < fromIntegral frmHLength) (skip $ fromIntegral frmHLength - (endOffset - beginOffset)) return JpgFrameHeader { jpgFrameHeaderLength = frmHLength , jpgSamplePrecision = samplePrec , jpgHeight = h , jpgWidth = w , jpgImageComponentCount = compCount , jpgComponents = components } put v = do putWord16be $ jpgFrameHeaderLength v putWord8 $ jpgSamplePrecision v putWord16be $ jpgHeight v putWord16be $ jpgWidth v putWord8 $ jpgImageComponentCount v mapM_ put $ jpgComponents v instance Binary JpgScanSpecification where put v = do put $ componentSelector v put4BitsOfEach (dcEntropyCodingTable v) $ acEntropyCodingTable v get = do compSel <- get (dc, ac) <- get4BitOfEach return JpgScanSpecification { componentSelector = compSel , dcEntropyCodingTable = dc , acEntropyCodingTable = ac } instance Binary JpgScanHeader where get = do thisScanLength <- getWord16be compCount <- getWord8 comp <- replicateM (fromIntegral compCount) get specBeg <- get specEnd <- get (approxHigh, approxLow) <- get4BitOfEach return JpgScanHeader { scanLength = thisScanLength, scanComponentCount = compCount, scans = comp, spectralSelection = (specBeg, specEnd), successiveApproxHigh = approxHigh, successiveApproxLow = approxLow } put v = do putWord16be $ scanLength v putWord8 $ scanComponentCount v mapM_ put $ scans v putWord8 . fst $ spectralSelection v putWord8 . snd $ spectralSelection v put4BitsOfEach (successiveApproxHigh v) $ successiveApproxLow v {-# INLINE createEmptyMutableMacroBlock #-} -- | Create a new macroblock with the good array size createEmptyMutableMacroBlock :: (Storable a, Num a) => ST s (MutableMacroBlock s a) createEmptyMutableMacroBlock = M.replicate 64 0 printMacroBlock :: (Storable a, PrintfArg a) => MutableMacroBlock s a -> ST s String printMacroBlock block = pLn 0 where pLn 64 = return "===============================\n" pLn i = do v <- block `M.unsafeRead` i vn <- pLn (i+1) return $ printf (if i `mod` 8 == 0 then "\n%5d " else "%5d ") v ++ vn printPureMacroBlock :: (Storable a, PrintfArg a) => MacroBlock a -> String printPureMacroBlock block = pLn 0 where pLn 64 = "===============================\n" pLn i = str ++ pLn (i + 1) where str | i `mod` 8 == 0 = printf "\n%5d " v | otherwise = printf "%5d" v v = block VS.! i {-# INLINE dctBlockSize #-} dctBlockSize :: Num a => a dctBlockSize = 8 JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Common.hs0000644000000000000000000002170312763046173017721 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Codec.Picture.Jpg.Common ( DctCoefficients , JpgUnpackerParameter( .. ) , decodeInt , dcCoefficientDecode , deQuantize , decodeRrrrSsss , zigZagReorderForward , zigZagReorderForwardv , zigZagReorder , inverseDirectCosineTransform , unpackInt , unpackMacroBlock , rasterMap , decodeMacroBlock , decodeRestartInterval , toBlockSize ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<$>) ) #endif import Control.Monad( when ) import Control.Monad.ST( ST, runST ) import Data.Bits( unsafeShiftL, unsafeShiftR, (.&.) ) import Data.Int( Int16, Int32 ) import Data.Maybe( fromMaybe ) import Data.Word( Word8 ) import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Foreign.Storable ( Storable ) import Codec.Picture.Types import Codec.Picture.BitWriter import Codec.Picture.Jpg.Types import Codec.Picture.Jpg.FastIdct import Codec.Picture.Jpg.DefaultTable -- | Same as for DcCoefficient, to provide nicer type signatures type DctCoefficients = DcCoefficient data JpgUnpackerParameter = JpgUnpackerParameter { dcHuffmanTree :: !HuffmanPackedTree , acHuffmanTree :: !HuffmanPackedTree , componentIndex :: {-# UNPACK #-} !Int , restartInterval :: {-# UNPACK #-} !Int , componentWidth :: {-# UNPACK #-} !Int , componentHeight :: {-# UNPACK #-} !Int , subSampling :: !(Int, Int) , coefficientRange :: !(Int, Int) , successiveApprox :: !(Int, Int) , readerIndex :: {-# UNPACK #-} !Int -- | When in progressive mode, we can have many -- color in a scan are only one. The indices changes -- on this fact, when mixed, there is whole -- MCU for all color components, spanning multiple -- block lines. With only one color component we use -- the normal raster order. , indiceVector :: {-# UNPACK #-} !Int , blockIndex :: {-# UNPACK #-} !Int , blockMcuX :: {-# UNPACK #-} !Int , blockMcuY :: {-# UNPACK #-} !Int } deriving Show toBlockSize :: Int -> Int toBlockSize v = (v + 7) `div` 8 decodeRestartInterval :: BoolReader s Int32 decodeRestartInterval = return (-1) {- do bits <- replicateM 8 getNextBitJpg if bits == replicate 8 True then do marker <- replicateM 8 getNextBitJpg return $ packInt marker else return (-1) -} {-# INLINE decodeInt #-} decodeInt :: Int -> BoolReader s Int32 decodeInt ssss = do signBit <- getNextBitJpg let dataRange = 1 `unsafeShiftL` fromIntegral (ssss - 1) leftBitCount = ssss - 1 -- First following bits store the sign of the coefficient, and counted in -- SSSS, so the bit count for the int, is ssss - 1 if signBit then (\w -> dataRange + fromIntegral w) <$> unpackInt leftBitCount else (\w -> 1 - dataRange * 2 + fromIntegral w) <$> unpackInt leftBitCount decodeRrrrSsss :: HuffmanPackedTree -> BoolReader s (Int, Int) decodeRrrrSsss tree = do rrrrssss <- huffmanPackedDecode tree let rrrr = (rrrrssss `unsafeShiftR` 4) .&. 0xF ssss = rrrrssss .&. 0xF pure (fromIntegral rrrr, fromIntegral ssss) dcCoefficientDecode :: HuffmanPackedTree -> BoolReader s DcCoefficient dcCoefficientDecode dcTree = do ssss <- huffmanPackedDecode dcTree if ssss == 0 then return 0 else fromIntegral <$> decodeInt (fromIntegral ssss) -- | Apply a quantization matrix to a macroblock {-# INLINE deQuantize #-} deQuantize :: MacroBlock Int16 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) deQuantize table block = update 0 where update 64 = return block update i = do val <- block `M.unsafeRead` i let finalValue = val * (table `VS.unsafeIndex` i) (block `M.unsafeWrite` i) finalValue update $ i + 1 inverseDirectCosineTransform :: MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) inverseDirectCosineTransform mBlock = fastIdct mBlock >>= mutableLevelShift zigZagOrder :: MacroBlock Int zigZagOrder = makeMacroBlock $ concat [[ 0, 1, 5, 6,14,15,27,28] ,[ 2, 4, 7,13,16,26,29,42] ,[ 3, 8,12,17,25,30,41,43] ,[ 9,11,18,24,31,40,44,53] ,[10,19,23,32,39,45,52,54] ,[20,22,33,38,46,51,55,60] ,[21,34,37,47,50,56,59,61] ,[35,36,48,49,57,58,62,63] ] zigZagReorderForwardv :: (Storable a, Num a) => VS.Vector a -> VS.Vector a zigZagReorderForwardv vec = runST $ do v <- M.new 64 mv <- VS.thaw vec zigZagReorderForward v mv >>= VS.freeze zigZagOrderForward :: MacroBlock Int zigZagOrderForward = VS.generate 64 inv where inv i = fromMaybe 0 $ VS.findIndex (i ==) zigZagOrder zigZagReorderForward :: (Storable a) => MutableMacroBlock s a -> MutableMacroBlock s a -> ST s (MutableMacroBlock s a) {-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int32 -> MutableMacroBlock s Int32 -> ST s (MutableMacroBlock s Int32) #-} {-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) #-} {-# SPECIALIZE INLINE zigZagReorderForward :: MutableMacroBlock s Word8 -> MutableMacroBlock s Word8 -> ST s (MutableMacroBlock s Word8) #-} zigZagReorderForward zigzaged block = ordering zigZagOrderForward >> return zigzaged where ordering !table = reorder (0 :: Int) where reorder !i | i >= 64 = return () reorder i = do let idx = table `VS.unsafeIndex` i v <- block `M.unsafeRead` idx (zigzaged `M.unsafeWrite` i) v reorder (i + 1) zigZagReorder :: MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) zigZagReorder zigzaged block = do let update i = do let idx = zigZagOrder `VS.unsafeIndex` i v <- block `M.unsafeRead` idx (zigzaged `M.unsafeWrite` i) v reorder 63 = update 63 reorder i = update i >> reorder (i + 1) reorder (0 :: Int) return zigzaged -- | Unpack an int of the given size encoded from MSB to LSB. unpackInt :: Int -> BoolReader s Int32 unpackInt = getNextIntJpg {-# INLINE rasterMap #-} rasterMap :: (Monad m) => Int -> Int -> (Int -> Int -> m ()) -> m () rasterMap width height f = liner 0 where liner y | y >= height = return () liner y = columner 0 where columner x | x >= width = liner (y + 1) columner x = f x y >> columner (x + 1) pixelClamp :: Int16 -> Word8 pixelClamp n = fromIntegral . min 255 $ max 0 n -- | Given a size coefficient (how much a pixel span horizontally -- and vertically), the position of the macroblock, return a list -- of indices and value to be stored in an array (like the final -- image) unpackMacroBlock :: Int -- ^ Component count -> Int -- ^ Width coefficient -> Int -- ^ Height coefficient -> Int -- ^ Component index -> Int -- ^ x -> Int -- ^ y -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () unpackMacroBlock compCount wCoeff hCoeff compIdx x y (MutableImage { mutableImageWidth = imgWidth, mutableImageHeight = imgHeight, mutableImageData = img }) block = rasterMap dctBlockSize dctBlockSize unpacker where unpacker i j = do let yBase = y * dctBlockSize + j * hCoeff compVal <- pixelClamp <$> (block `M.unsafeRead` (i + j * dctBlockSize)) rasterMap wCoeff hCoeff $ \wDup hDup -> do let xBase = x * dctBlockSize + i * wCoeff xPos = xBase + wDup yPos = yBase + hDup when (xPos < imgWidth && yPos < imgHeight) (do let mutableIdx = (xPos + yPos * imgWidth) * compCount + compIdx (img `M.unsafeWrite` mutableIdx) compVal) -- | This is one of the most important function of the decoding, -- it form the barebone decoding pipeline for macroblock. It's all -- there is to know for macro block transformation decodeMacroBlock :: MacroBlock DctCoefficients -> MutableMacroBlock s Int16 -> MutableMacroBlock s Int16 -> ST s (MutableMacroBlock s Int16) decodeMacroBlock quantizationTable zigZagBlock block = deQuantize quantizationTable block >>= zigZagReorder zigZagBlock >>= inverseDirectCosineTransform JuicyPixels-3.2.8/src/Codec/Picture/Jpg/Progressive.hs0000644000000000000000000003230212763046173020776 0ustar0000000000000000{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} module Codec.Picture.Jpg.Progressive ( JpgUnpackerParameter( .. ) , progressiveUnpack ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( pure, (<$>) ) #endif import Control.Monad( when, unless, forM_ ) import Control.Monad.ST( ST ) import Control.Monad.Trans( lift ) import Data.Bits( (.&.), (.|.), unsafeShiftL ) import Data.Int( Int16, Int32 ) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import Data.Vector( (!) ) import qualified Data.Vector.Mutable as M import qualified Data.Vector.Storable.Mutable as MS import Codec.Picture.Types import Codec.Picture.BitWriter import Codec.Picture.Jpg.Common import Codec.Picture.Jpg.Types import Codec.Picture.Jpg.DefaultTable createMcuLineIndices :: JpgComponent -> Int -> Int -> V.Vector (VS.Vector Int) createMcuLineIndices param imgWidth mcuWidth = V.fromList $ VS.fromList <$> [indexSolo, indexMulti] where compW = fromIntegral $ horizontalSamplingFactor param compH = fromIntegral $ verticalSamplingFactor param imageBlockSize = toBlockSize imgWidth indexSolo = take (imageBlockSize * compH) [0 ..] indexMulti = [(mcu + y * mcuWidth) * compW + x | mcu <- [0 .. mcuWidth - 1] , y <- [0 .. compH - 1] , x <- [0 .. compW - 1] ] decodeFirstDC :: JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32 decodeFirstDC params dcCoeffs block eobrun = unpack >> pure eobrun where unpack = do (dcDeltaCoefficient) <- dcCoefficientDecode $ dcHuffmanTree params previousDc <- lift $ dcCoeffs `MS.unsafeRead` componentIndex params let neoDcCoefficient = previousDc + dcDeltaCoefficient approxLow = fst $ successiveApprox params scaledDc = neoDcCoefficient `unsafeShiftL` approxLow lift $ (block `MS.unsafeWrite` 0) scaledDc lift $ (dcCoeffs `MS.unsafeWrite` componentIndex params) neoDcCoefficient decodeRefineDc :: JpgUnpackerParameter -> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32 decodeRefineDc params _ block eobrun = unpack >> pure eobrun where approxLow = fst $ successiveApprox params plusOne = 1 `unsafeShiftL` approxLow unpack = do bit <- getNextBitJpg when bit . lift $ do v <- block `MS.unsafeRead` 0 (block `MS.unsafeWrite` 0) $ v .|. plusOne decodeFirstAc :: JpgUnpackerParameter -> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32 decodeFirstAc _params _ _block eobrun | eobrun > 0 = pure $ eobrun - 1 decodeFirstAc params _ block _ = unpack startIndex where (startIndex, maxIndex) = coefficientRange params (low, _) = successiveApprox params unpack n | n > maxIndex = pure 0 unpack n = do rrrrssss <- decodeRrrrSsss $ acHuffmanTree params case rrrrssss of (0xF, 0) -> unpack $ n + 16 ( 0, 0) -> return 0 ( r, 0) -> eobrun <$> unpackInt r where eobrun lowBits = (1 `unsafeShiftL` r) - 1 + lowBits ( r, s) -> do let n' = n + r val <- (`unsafeShiftL` low) <$> decodeInt s lift . (block `MS.unsafeWrite` n') $ fromIntegral val unpack $ n' + 1 decodeRefineAc :: forall a s. JpgUnpackerParameter -> a -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32 decodeRefineAc params _ block eobrun | eobrun == 0 = unpack startIndex | otherwise = performEobRun startIndex >> return (eobrun - 1) where (startIndex, maxIndex) = coefficientRange params (low, _) = successiveApprox params plusOne = 1 `unsafeShiftL` low minusOne = (-1) `unsafeShiftL` low getBitVal = do v <- getNextBitJpg pure $ if v then plusOne else minusOne performEobRun idx | idx > maxIndex = pure () performEobRun idx = do coeff <- lift $ block `MS.unsafeRead` idx if coeff /= 0 then do bit <- getNextBitJpg case (bit, (coeff .&. plusOne) == 0) of (False, _) -> performEobRun $ idx + 1 (True, False) -> performEobRun $ idx + 1 (True, True) -> do let newVal | coeff >= 0 = coeff + plusOne | 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 0xF idx unpack $ idx' + 1 ( r, 0) -> do lowBits <- unpackInt r let newEobRun = (1 `unsafeShiftL` r) + lowBits - 1 performEobRun idx pure newEobRun ( r, _) -> do val <- getBitVal 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 - 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) $ 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 type Unpacker s = JpgUnpackerParameter -> MS.STVector s Int16 -> MutableMacroBlock s Int16 -> Int32 -> BoolReader s Int32 prepareUnpacker :: [([(JpgUnpackerParameter, a)], L.ByteString)] -> ST s ( V.Vector (V.Vector (JpgUnpackerParameter, Unpacker s)) , M.STVector s BoolState) prepareUnpacker lst = do let boolStates = V.fromList $ map snd infos vec <- V.unsafeThaw boolStates return (V.fromList $ map fst infos, vec) where infos = map prepare lst prepare ([], _) = error "progressiveUnpack, no component" prepare (whole@((param, _) : _) , byteString) = (V.fromList $ map (\(p,_) -> (p, unpacker)) whole, boolReader) where unpacker = selection (successiveApprox param) (coefficientRange param) boolReader = initBoolStateJpg . B.concat $ L.toChunks byteString selection (_, 0) (0, _) = decodeFirstDC selection (_, 0) _ = decodeFirstAc selection _ (0, _) = decodeRefineDc selection _ _ = decodeRefineAc data ComponentData s = ComponentData { componentIndices :: V.Vector (VS.Vector Int) , componentBlocks :: V.Vector (MutableMacroBlock s Int16) , componentId :: !Int , componentBlockCount :: !Int } -- | Iteration from 0 to n in monadic context, without data -- keeping. lineMap :: (Monad m) => Int -> (Int -> m ()) -> m () {-# INLINE lineMap #-} lineMap count f = go 0 where go n | n >= count = return () go n = f n >> go (n + 1) progressiveUnpack :: (Int, Int) -> JpgFrameHeader -> V.Vector (MacroBlock Int16) -> [([(JpgUnpackerParameter, a)], L.ByteString)] -> ST s (MutableImage s PixelYCbCr8) progressiveUnpack (maxiW, maxiH) frame quants lst = do (unpackers, readers) <- prepareUnpacker lst allBlocks <- mapM allocateWorkingBlocks . zip [0..] $ jpgComponents frame :: ST s [ComponentData s] let scanCount = length lst restartIntervalValue = case lst of ((p,_):_,_): _ -> restartInterval p _ -> -1 dcCoeffs <- MS.replicate imgComponentCount 0 eobRuns <- MS.replicate (length lst) 0 workBlock <- createEmptyMutableMacroBlock writeIndices <- MS.replicate imgComponentCount (0 :: Int) restartIntervals <- MS.replicate scanCount restartIntervalValue let elementCount = imgWidth * imgHeight * fromIntegral imgComponentCount img <- MutableImage imgWidth imgHeight <$> MS.replicate elementCount 128 let processRestartInterval = forM_ [0 .. scanCount - 1] $ \ix -> do v <- restartIntervals `MS.read` ix if v == 0 then do -- reset DC prediction when (ix == 0) (MS.set dcCoeffs 0) reader <- readers `M.read` ix (_, updated) <- runBoolReaderWith reader $ byteAlignJpg >> decodeRestartInterval (readers `M.write` ix) updated (eobRuns `MS.unsafeWrite` ix) 0 (restartIntervals `MS.unsafeWrite` ix) $ restartIntervalValue - 1 else (restartIntervals `MS.unsafeWrite` ix) $ v - 1 lineMap imageMcuHeight $ \mmY -> do -- Reset all blocks to 0 forM_ allBlocks $ V.mapM_ (`MS.set` 0) . componentBlocks MS.set writeIndices 0 lineMap imageMcuWidth $ \_mmx -> do processRestartInterval V.forM_ unpackers $ V.mapM_ $ \(unpackParam, unpacker) -> do boolState <- readers `M.read` readerIndex unpackParam eobrun <- eobRuns `MS.read` readerIndex unpackParam let componentNumber = componentIndex unpackParam writeIndex <- writeIndices `MS.read` componentNumber let componentData = allBlocks !! componentNumber -- We get back the correct block indices for the number of component -- in the current scope (precalculated) indexVector = componentIndices componentData ! indiceVector unpackParam maxIndexLength = VS.length indexVector unless (writeIndex + blockIndex unpackParam >= maxIndexLength) $ do let realIndex = indexVector VS.! (writeIndex + blockIndex unpackParam) writeBlock = componentBlocks componentData ! realIndex (eobrun', state) <- runBoolReaderWith boolState $ unpacker unpackParam dcCoeffs writeBlock eobrun (readers `M.write` readerIndex unpackParam) state (eobRuns `MS.write` readerIndex unpackParam) eobrun' -- Update the write indices forM_ allBlocks $ \comp -> do writeIndex <- writeIndices `MS.read` componentId comp let newIndex = writeIndex + componentBlockCount comp (writeIndices `MS.write` componentId comp) newIndex forM_ allBlocks $ \compData -> do let compBlocks = componentBlocks compData cId = componentId compData 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 ch8 = maxiH - fromIntegral (verticalSamplingFactor comp) + 1 rasterMap (imageMcuWidth * compW) compH $ \rx y -> do let ry = mmY * maxiH + y block = compBlocks ! (y * imageMcuWidth * compW + rx) transformed <- decodeMacroBlock table workBlock block unpackMacroBlock imgComponentCount cw8 ch8 cId (rx * cw8) ry img transformed return img where imgComponentCount = length $ jpgComponents frame imgWidth = fromIntegral $ jpgWidth frame imgHeight = fromIntegral $ jpgHeight frame imageBlockWidth = toBlockSize imgWidth imageBlockHeight = toBlockSize imgHeight imageMcuWidth = (imageBlockWidth + (maxiW - 1)) `div` maxiW imageMcuHeight = (imageBlockHeight + (maxiH - 1)) `div` maxiH allocateWorkingBlocks (ix, comp) = do let blockCount = hSample * vSample * imageMcuWidth * 2 blocks <- V.replicateM blockCount createEmptyMutableMacroBlock return ComponentData { componentBlocks = blocks , componentIndices = createMcuLineIndices comp imgWidth imageMcuWidth , componentBlockCount = hSample * vSample , componentId = ix } where hSample = fromIntegral $ horizontalSamplingFactor comp vSample = fromIntegral $ verticalSamplingFactor comp JuicyPixels-3.2.8/src/Codec/Picture/Gif/LZW.hs0000644000000000000000000001511212763010461017116 0ustar0000000000000000{-# LANGUAGE CPP #-} module Codec.Picture.Gif.LZW( decodeLzw, decodeLzwTiff ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) #endif import Data.Word( Word8 ) import Control.Monad( when, unless ) import Data.Bits( (.&.) ) import Control.Monad.ST( ST ) import Control.Monad.Trans.Class( MonadTrans, lift ) import Foreign.Storable ( Storable ) import qualified Data.ByteString as B import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.BitWriter {-# INLINE (.!!!.) #-} (.!!!.) :: (Storable a) => M.STVector s a -> Int -> ST s a (.!!!.) = M.unsafeRead {-M.read-} {-# INLINE (..!!!..) #-} (..!!!..) :: (MonadTrans t, Storable a) => M.STVector s a -> Int -> t (ST s) a (..!!!..) v idx = lift $ v .!!!. idx {-# INLINE (.<-.) #-} (.<-.) :: (Storable a) => M.STVector s a -> Int -> a -> ST s () (.<-.) = M.unsafeWrite {-M.write-} {-# INLINE (..<-..) #-} (..<-..) :: (MonadTrans t, Storable a) => M.STVector s a -> Int -> a -> t (ST s) () (..<-..) v idx = lift . (v .<-. idx) duplicateData :: (MonadTrans t, Storable a) => M.STVector s a -> M.STVector s a -> Int -> Int -> Int -> t (ST s) () duplicateData src dest sourceIndex size destIndex = lift $ aux sourceIndex destIndex where endIndex = sourceIndex + size aux i _ | i == endIndex = return () aux i j = do src .!!!. i >>= (dest .<-. j) aux (i + 1) (j + 1) rangeSetter :: (Storable a, Num a) => Int -> M.STVector s a -> ST s (M.STVector s a) rangeSetter count vec = aux 0 where aux n | n == count = return vec aux n = (vec .<-. n) (fromIntegral n) >> aux (n + 1) decodeLzw :: B.ByteString -> Int -> Int -> M.STVector s Word8 -> BoolReader s () decodeLzw str maxBitKey initialKey outVec = do setDecodedString str lzw GifVariant maxBitKey initialKey 0 outVec isOldTiffLZW :: B.ByteString -> Bool isOldTiffLZW str = firstByte == 0 && secondByte == 1 where firstByte = str `B.index` 0 secondByte = (str `B.index` 1) .&. 1 decodeLzwTiff :: B.ByteString -> M.STVector s Word8 -> Int -> BoolReader s() decodeLzwTiff str outVec initialWriteIdx = do if isOldTiffLZW str then setDecodedString str else setDecodedStringMSB str let variant | isOldTiffLZW str = OldTiffVariant | otherwise = TiffVariant lzw variant 12 9 initialWriteIdx outVec data TiffVariant = GifVariant | TiffVariant | OldTiffVariant deriving Eq -- | Gif image constraint from spec-gif89a, code size max : 12 bits. lzw :: TiffVariant -> Int -> Int -> Int -> M.STVector s Word8 -> BoolReader s () lzw variant nMaxBitKeySize initialKeySize initialWriteIdx outVec = do -- Allocate buffer of maximum size. lzwData <- lift (M.replicate maxDataSize 0) >>= resetArray lzwOffsetTable <- lift (M.replicate tableEntryCount 0) >>= resetArray lzwSizeTable <- lift $ M.replicate tableEntryCount 0 lift $ lzwSizeTable `M.set` 1 let firstVal code = do dataOffset <- lzwOffsetTable ..!!!.. code lzwData ..!!!.. dataOffset writeString at code = do dataOffset <- lzwOffsetTable ..!!!.. code dataSize <- lzwSizeTable ..!!!.. code when (at + dataSize <= maxWrite) $ duplicateData lzwData outVec dataOffset dataSize at return dataSize addString pos at code val = do dataOffset <- lzwOffsetTable ..!!!.. code dataSize <- lzwSizeTable ..!!!.. code when (pos < tableEntryCount) $ do (lzwOffsetTable ..<-.. pos) at (lzwSizeTable ..<-.. pos) $ dataSize + 1 when (at + dataSize + 1 <= maxDataSize) $ do duplicateData lzwData lzwData dataOffset dataSize at (lzwData ..<-.. (at + dataSize)) val return $ dataSize + 1 maxWrite = M.length outVec loop outWriteIdx writeIdx dicWriteIdx codeSize oldCode code | outWriteIdx >= maxWrite = return () | code == endOfInfo = return () | code == clearCode = do toOutput <- getNextCode startCodeSize unless (toOutput == endOfInfo) $ do dataSize <- writeString outWriteIdx toOutput getNextCode startCodeSize >>= loop (outWriteIdx + dataSize) firstFreeIndex firstFreeIndex startCodeSize toOutput | otherwise = do (written, dicAdd) <- if code >= writeIdx then do c <- firstVal oldCode wroteSize <- writeString outWriteIdx oldCode (outVec ..<-.. (outWriteIdx + wroteSize)) c addedSize <- addString writeIdx dicWriteIdx oldCode c return (wroteSize + 1, addedSize) else do wroteSize <- writeString outWriteIdx code c <- firstVal code addedSize <- addString writeIdx dicWriteIdx oldCode c return (wroteSize, addedSize) let new_code_size = updateCodeSize codeSize $ writeIdx + 1 getNextCode new_code_size >>= loop (outWriteIdx + written) (writeIdx + 1) (dicWriteIdx + dicAdd) new_code_size code getNextCode startCodeSize >>= loop initialWriteIdx firstFreeIndex firstFreeIndex startCodeSize 0 where tableEntryCount = 2 ^ min 12 nMaxBitKeySize maxDataSize = tableEntryCount `div` 2 * (1 + tableEntryCount) + 1 isNewTiff = variant == TiffVariant (switchOffset, isTiffVariant) = case variant of GifVariant -> (0, False) TiffVariant -> (1, True) OldTiffVariant -> (0, True) initialElementCount = 2 ^ initialKeySize :: Int clearCode | isTiffVariant = 256 | otherwise = initialElementCount endOfInfo | isTiffVariant = 257 | otherwise = clearCode + 1 startCodeSize | isTiffVariant = initialKeySize | otherwise = initialKeySize + 1 firstFreeIndex = endOfInfo + 1 resetArray a = lift $ rangeSetter initialElementCount a updateCodeSize codeSize writeIdx | writeIdx == 2 ^ codeSize - switchOffset = min 12 $ codeSize + 1 | otherwise = codeSize getNextCode s | isNewTiff = fromIntegral <$> getNextBitsMSBFirst s | otherwise = fromIntegral <$> getNextBitsLSBFirst s JuicyPixels-3.2.8/src/Codec/Picture/Gif/LZWEncoding.hs0000644000000000000000000000636012763010461020572 0ustar0000000000000000{-# LANGUAGE BangPatterns, CPP #-} module Codec.Picture.Gif.LZWEncoding( lzwEncode ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>) ) import Data.Monoid( mempty ) #endif import Control.Monad.ST( runST ) import qualified Data.ByteString.Lazy as L import Data.Maybe( fromMaybe ) import Data.Word( Word8 ) #if MIN_VERSION_containers(0,5,0) import qualified Data.IntMap.Strict as I #else import qualified Data.IntMap as I #endif import qualified Data.Vector.Storable as V import Codec.Picture.BitWriter type Trie = I.IntMap TrieNode data TrieNode = TrieNode { trieIndex :: {-# UNPACK #-} !Int , trieSub :: !Trie } emptyNode :: TrieNode emptyNode = TrieNode { trieIndex = -1 , trieSub = mempty } initialTrie :: Trie initialTrie = I.fromList [(i, emptyNode { trieIndex = i }) | i <- [0 .. 255]] lookupUpdate :: V.Vector Word8 -> Int -> Int -> Trie -> (Int, Int, Trie) lookupUpdate vector freeIndex firstIndex trie = matchUpdate $ go trie 0 firstIndex where matchUpdate (lzwOutputIndex, nextReadIndex, sub) = (lzwOutputIndex, nextReadIndex, fromMaybe trie sub) maxi = V.length vector go !currentTrie !prevIndex !index | index >= maxi = (prevIndex, index, Nothing) | otherwise = case I.lookup val currentTrie of Just (TrieNode ix subTable) -> let (lzwOutputIndex, nextReadIndex, newTable) = go subTable ix $ index + 1 tableUpdater t = I.insert val (TrieNode ix t) currentTrie in (lzwOutputIndex, nextReadIndex, tableUpdater <$> newTable) Nothing | index == maxi -> (prevIndex, index, Nothing) | otherwise -> (prevIndex, index, Just $ I.insert val newNode currentTrie) where val = fromIntegral $ vector `V.unsafeIndex` index newNode = emptyNode { trieIndex = freeIndex } lzwEncode :: Int -> V.Vector Word8 -> L.ByteString lzwEncode initialKeySize vec = runST $ do bitWriter <- newWriteStateRef let updateCodeSize 12 writeIdx _ | writeIdx == 2 ^ (12 :: Int) - 1 = do writeBitsGif bitWriter (fromIntegral clearCode) 12 return (startCodeSize, firstFreeIndex, initialTrie) updateCodeSize codeSize writeIdx trie | writeIdx == 2 ^ codeSize = return (codeSize + 1, writeIdx + 1, trie) | otherwise = return (codeSize, writeIdx + 1, trie) go readIndex (codeSize, _, _) | readIndex >= maxi = writeBitsGif bitWriter (fromIntegral endOfInfo) codeSize go !readIndex (!codeSize, !writeIndex, !trie) = do let (indexToWrite, endIndex, trie') = lookuper writeIndex readIndex trie writeBitsGif bitWriter (fromIntegral indexToWrite) codeSize updateCodeSize codeSize writeIndex trie' >>= go endIndex writeBitsGif bitWriter (fromIntegral clearCode) startCodeSize go 0 (startCodeSize, firstFreeIndex, initialTrie) finalizeBoolWriter bitWriter where maxi = V.length vec startCodeSize = initialKeySize + 1 clearCode = 2 ^ initialKeySize :: Int endOfInfo = clearCode + 1 firstFreeIndex = endOfInfo + 1 lookuper = lookupUpdate vec JuicyPixels-3.2.8/src/Codec/Picture/Png/Export.hs0000644000000000000000000002173112763010461017746 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ScopedTypeVariables #-} -- | Module implementing a basic png export, no filtering is applyed, but -- export at least valid images. module Codec.Picture.Png.Export( PngSavable( .. ) , writePng , encodeDynamicPng , writeDynamicPng , encodePalettedPng , encodePalettedPngWithMetadata ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) #endif import Control.Monad( forM_ ) import Control.Monad.ST( ST, runST ) import Data.Bits( unsafeShiftR, (.&.) ) import Data.Binary( encode ) import Data.Monoid( (<>) ) import Data.Word(Word8, Word16) import qualified Codec.Compression.Zlib as Z import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as Lb import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Codec.Picture.Types import Codec.Picture.Png.Type import Codec.Picture.Png.Metadata import Codec.Picture.Metadata( Metadatas ) import Codec.Picture.VectorByteConversion( blitVector, toByteString ) -- | Encode an image into a png if possible. class PngSavable a where -- | Transform an image into a png encoded bytestring, ready -- to be written as a file. encodePng :: Image a -> Lb.ByteString encodePng = encodePngWithMetadata mempty -- | Encode a png using some metadatas. The following metadata keys will -- be stored in a `tEXt` field : -- -- * 'Codec.Picture.Metadata.Title' -- * 'Codec.Picture.Metadata.Description' -- * 'Codec.Picture.Metadata.Author' -- * 'Codec.Picture.Metadata.Copyright' -- * 'Codec.Picture.Metadata.Software' -- * 'Codec.Picture.Metadata.Comment' -- * 'Codec.Picture.Metadata.Disclaimer' -- * 'Codec.Picture.Metadata.Source' -- * 'Codec.Picture.Metadata.Warning' -- * 'Codec.Picture.Metadata.Unknown' using the key present in the constructor. -- -- the followings metadata will bes tored in the `gAMA` chunk. -- -- * 'Codec.Picture.Metadata.Gamma' -- -- The followings metadata will be stored in a `pHYs` chunk -- -- * 'Codec.Picture.Metadata.DpiX' -- * 'Codec.Picture.Metadata.DpiY' encodePngWithMetadata :: Metadatas -> Image a -> Lb.ByteString preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr preparePngHeader (Image { imageWidth = w, imageHeight = h }) imgType depth = PngIHdr { width = fromIntegral w , height = fromIntegral h , bitDepth = depth , colourType = imgType , compressionMethod = 0 , filterMethod = 0 , interlaceMethod = PngNoInterlace } -- | Helper function to directly write an image as a png on disk. writePng :: (PngSavable pixel) => FilePath -> Image pixel -> IO () writePng path img = Lb.writeFile path $ encodePng img endChunk :: PngRawChunk endChunk = mkRawChunk iENDSignature mempty prepareIDatChunk :: Lb.ByteString -> PngRawChunk prepareIDatChunk = mkRawChunk iDATSignature genericEncode16BitsPng :: forall px. (Pixel px, PixelBaseComponent px ~ Word16) => PngImageType -> Metadatas -> Image px -> Lb.ByteString genericEncode16BitsPng imgKind metas image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = encode PngRawImage { header = hdr , chunks = encodeMetadatas metas <> [ prepareIDatChunk imgEncodedData , endChunk ] } where hdr = preparePngHeader image imgKind 16 zero = B.singleton 0 compCount = componentCount (undefined :: px) lineSize = compCount * w blitToByteString vec = blitVector vec 0 (lineSize * 2) encodeLine line = blitToByteString $ runST $ do finalVec <- M.new $ lineSize * 2 :: ST s (M.STVector s Word8) let baseIndex = line * lineSize forM_ [0 .. lineSize - 1] $ \ix -> do let v = arr `VS.unsafeIndex` (baseIndex + ix) high = fromIntegral $ (v `unsafeShiftR` 8) .&. 0xFF low = fromIntegral $ v .&. 0xFF (finalVec `M.unsafeWrite` (ix * 2 + 0)) high (finalVec `M.unsafeWrite` (ix * 2 + 1)) low VS.unsafeFreeze finalVec imgEncodedData = Z.compress . Lb.fromChunks $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] preparePalette :: Palette -> PngRawChunk preparePalette pal = PngRawChunk { chunkLength = fromIntegral $ imageWidth pal * 3 , chunkType = pLTESignature , chunkCRC = pngComputeCrc [pLTESignature, binaryData] , chunkData = binaryData } where binaryData = Lb.fromChunks [toByteString $ imageData pal] genericEncodePng :: forall px. (Pixel px, PixelBaseComponent px ~ Word8) => Maybe Palette -> PngImageType -> Metadatas -> Image px -> Lb.ByteString genericEncodePng palette imgKind metas image@(Image { imageWidth = w, imageHeight = h, imageData = arr }) = encode PngRawImage { header = hdr , chunks = encodeMetadatas metas <> prependPalette palette [ prepareIDatChunk imgEncodedData , endChunk]} where hdr = preparePngHeader image imgKind 8 zero = B.singleton 0 compCount = componentCount (undefined :: px) prependPalette Nothing l = l prependPalette (Just p) l = preparePalette p : l lineSize = compCount * w encodeLine line = blitVector arr (line * lineSize) lineSize imgEncodedData = Z.compress . Lb.fromChunks $ concat [[zero, encodeLine line] | line <- [0 .. h - 1]] instance PngSavable PixelRGBA8 where encodePngWithMetadata = genericEncodePng Nothing PngTrueColourWithAlpha instance PngSavable PixelRGB8 where encodePngWithMetadata = genericEncodePng Nothing PngTrueColour instance PngSavable Pixel8 where encodePngWithMetadata = genericEncodePng Nothing PngGreyscale instance PngSavable PixelYA8 where encodePngWithMetadata = genericEncodePng Nothing PngGreyscaleWithAlpha instance PngSavable PixelYA16 where encodePngWithMetadata = genericEncode16BitsPng PngGreyscaleWithAlpha instance PngSavable Pixel16 where encodePngWithMetadata = genericEncode16BitsPng PngGreyscale instance PngSavable PixelRGB16 where encodePngWithMetadata = genericEncode16BitsPng PngTrueColour instance PngSavable PixelRGBA16 where encodePngWithMetadata = genericEncode16BitsPng PngTrueColourWithAlpha -- | Write a dynamic image in a .png image file if possible. -- The same restriction as encodeDynamicPng apply. writeDynamicPng :: FilePath -> DynamicImage -> IO (Either String Bool) writeDynamicPng path img = case encodeDynamicPng img of Left err -> return $ Left err Right b -> Lb.writeFile path b >> return (Right True) -- | Encode a paletted image as a color indexed 8-bit PNG. -- the palette must have between 1 and 256 values in it. encodePalettedPng :: Palette -> Image Pixel8 -> Either String Lb.ByteString encodePalettedPng = encodePalettedPngWithMetadata mempty -- | Equivalent to 'encodePalettedPng' but allow writing of metadatas. encodePalettedPngWithMetadata :: Metadatas -> Palette -> Image Pixel8 -> Either String Lb.ByteString encodePalettedPngWithMetadata metas pal img | w <= 0 || w > 256 || h /= 1 = Left "Invalid palette" | VS.any isTooBig $ imageData img = Left "Image contains indexes absent from the palette" | otherwise = Right $ genericEncodePng (Just pal) PngIndexedColor metas img where w = imageWidth pal h = imageHeight pal isTooBig v = fromIntegral v >= w -- | Encode a dynamic image in PNG if possible, supported images are: -- -- * 'ImageY8' -- -- * 'ImageY16' -- -- * 'ImageYA8' -- -- * 'ImageYA16' -- -- * 'ImageRGB8' -- -- * 'ImageRGB16' -- -- * 'ImageRGBA8' -- -- * 'ImageRGBA16' -- encodeDynamicPng :: DynamicImage -> Either String Lb.ByteString encodeDynamicPng (ImageRGB8 img) = Right $ encodePng img encodeDynamicPng (ImageRGBA8 img) = Right $ encodePng img encodeDynamicPng (ImageY8 img) = Right $ encodePng img encodeDynamicPng (ImageY16 img) = Right $ encodePng img encodeDynamicPng (ImageYA8 img) = Right $ encodePng img encodeDynamicPng (ImageYA16 img) = Right $ encodePng img encodeDynamicPng (ImageRGB16 img) = Right $ encodePng img encodeDynamicPng (ImageRGBA16 img) = Right $ encodePng img encodeDynamicPng _ = Left "Unsupported image format for PNG export" JuicyPixels-3.2.8/src/Codec/Picture/Png/Type.hs0000644000000000000000000003667112763046173017430 0ustar0000000000000000{-# LANGUAGE CPP #-} -- | Low level png module, you should import 'Codec.Picture.Png' instead. module Codec.Picture.Png.Type( PngIHdr( .. ) , PngFilter( .. ) , PngInterlaceMethod( .. ) , PngPalette , PngImageType( .. ) , PngPhysicalDimension( .. ) , PngGamma( .. ) , PngUnit( .. ) , APngAnimationControl( .. ) , APngFrameDisposal( .. ) , APngBlendOp( .. ) , APngFrameControl( .. ) , parsePalette , pngComputeCrc , pLTESignature , iDATSignature , iENDSignature , tRNSSignature , tEXtSignature , zTXtSignature , gammaSignature , pHYsSignature , animationControlSignature -- * Low level types , ChunkSignature , PngRawImage( .. ) , PngChunk( .. ) , PngRawChunk( .. ) , PngLowLevel( .. ) , chunksWithSig , mkRawChunk ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>), (<*>), pure ) #endif import Control.Monad( when, replicateM ) import Data.Bits( xor, (.&.), unsafeShiftR ) import Data.Binary( Binary(..), Get, get ) import Data.Binary.Get( getWord8 , getWord32be , getLazyByteString ) import Data.Binary.Put( runPut , putWord8 , putWord32be , putLazyByteString ) import Data.Vector.Unboxed( Vector, fromListN, (!) ) import qualified Data.Vector.Storable as V import Data.List( foldl' ) import Data.Word( Word32, Word16, Word8 ) import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as LS import Codec.Picture.Types import Codec.Picture.InternalHelper -------------------------------------------------- ---- Types -------------------------------------------------- -- | Value used to identify a png chunk, must be 4 bytes long. type ChunkSignature = L.ByteString -- | Generic header used in PNG images. data PngIHdr = PngIHdr { width :: !Word32 -- ^ Image width in number of pixel , height :: !Word32 -- ^ Image height in number of pixel , bitDepth :: !Word8 -- ^ Number of bit per sample , colourType :: !PngImageType -- ^ Kind of png image (greyscale, true color, indexed...) , compressionMethod :: !Word8 -- ^ Compression method used , filterMethod :: !Word8 -- ^ Must be 0 , interlaceMethod :: !PngInterlaceMethod -- ^ If the image is interlaced (for progressive rendering) } deriving Show data PngUnit = PngUnitUnknown -- ^ 0 value | PngUnitMeter -- ^ 1 value instance Binary PngUnit where get = do v <- getWord8 pure $ case v of 0 -> PngUnitUnknown 1 -> PngUnitMeter _ -> PngUnitUnknown put v = case v of PngUnitUnknown -> putWord8 0 PngUnitMeter -> putWord8 1 data PngPhysicalDimension = PngPhysicalDimension { pngDpiX :: !Word32 , pngDpiY :: !Word32 , pngUnit :: !PngUnit } instance Binary PngPhysicalDimension where get = PngPhysicalDimension <$> getWord32be <*> getWord32be <*> get put (PngPhysicalDimension dpx dpy unit) = putWord32be dpx >> putWord32be dpy >> put unit newtype PngGamma = PngGamma { getPngGamma :: Double } instance Binary PngGamma where get = PngGamma . (/ 100000) . fromIntegral <$> getWord32be put = putWord32be . ceiling . (100000 *) . getPngGamma data APngAnimationControl = APngAnimationControl { animationFrameCount :: !Word32 , animationPlayCount :: !Word32 } deriving Show -- | Encoded in a Word8 data APngFrameDisposal -- | No disposal is done on this frame before rendering the -- next; the contents of the output buffer are left as is. -- Has Value 0 = APngDisposeNone -- | The frame's region of the output buffer is to be cleared -- to fully transparent black before rendering the next frame. -- Has Value 1 | APngDisposeBackground -- | the frame's region of the output buffer is to be reverted -- to the previous contents before rendering the next frame. -- Has Value 2 | APngDisposePrevious deriving Show -- | Encoded in a Word8 data APngBlendOp -- | Overwrite output buffer. has value '0' = APngBlendSource -- | Alpha blend to the output buffer. Has value '1' | APngBlendOver deriving Show data APngFrameControl = APngFrameControl { frameSequenceNum :: !Word32 -- ^ Starting from 0 , frameWidth :: !Word32 -- ^ Width of the following frame , frameHeight :: !Word32 -- ^ Height of the following frame , frameLeft :: !Word32 -- X position where to render the frame. , frameTop :: !Word32 -- Y position where to render the frame. , frameDelayNumerator :: !Word16 , frameDelayDenuminator :: !Word16 , frameDisposal :: !APngFrameDisposal , frameBlending :: !APngBlendOp } deriving Show -- | What kind of information is encoded in the IDAT section -- of the PngFile data PngImageType = PngGreyscale | PngTrueColour | PngIndexedColor | PngGreyscaleWithAlpha | PngTrueColourWithAlpha deriving Show -- | Raw parsed image which need to be decoded. data PngRawImage = PngRawImage { header :: PngIHdr , chunks :: [PngRawChunk] } -- | Palette with indices beginning at 0 to elemcount - 1 type PngPalette = Palette' PixelRGB8 -- | Parse a palette from a png chunk. parsePalette :: PngRawChunk -> Either String PngPalette parsePalette plte | chunkLength plte `mod` 3 /= 0 = Left "Invalid palette size" | otherwise = Palette' pixelCount . V.fromListN (3 * pixelCount) <$> pixels where pixelUnpacker = replicateM (fromIntegral pixelCount * 3) get pixelCount = fromIntegral $ chunkLength plte `div` 3 pixels = runGet pixelUnpacker (chunkData plte) -- | Data structure during real png loading/parsing data PngRawChunk = PngRawChunk { chunkLength :: Word32 , chunkType :: ChunkSignature , chunkCRC :: Word32 , chunkData :: L.ByteString } mkRawChunk :: ChunkSignature -> L.ByteString -> PngRawChunk mkRawChunk sig binaryData = PngRawChunk { chunkLength = fromIntegral $ L.length binaryData , chunkType = sig , chunkCRC = pngComputeCrc [sig, binaryData] , chunkData = binaryData } -- | PNG chunk representing some extra information found in the parsed file. data PngChunk = PngChunk { pngChunkData :: L.ByteString -- ^ The raw data inside the chunk , pngChunkSignature :: ChunkSignature -- ^ The name of the chunk. } -- | Low level access to PNG information data PngLowLevel a = PngLowLevel { pngImage :: Image a -- ^ The real uncompressed image , pngChunks :: [PngChunk] -- ^ List of raw chunk where some user data might be present. } -- | The pixels value should be : -- +---+---+ -- | c | b | -- +---+---+ -- | a | x | -- +---+---+ -- x being the current filtered pixel data PngFilter = -- | Filt(x) = Orig(x), Recon(x) = Filt(x) FilterNone -- | Filt(x) = Orig(x) - Orig(a), Recon(x) = Filt(x) + Recon(a) | FilterSub -- | Filt(x) = Orig(x) - Orig(b), Recon(x) = Filt(x) + Recon(b) | FilterUp -- | Filt(x) = Orig(x) - floor((Orig(a) + Orig(b)) / 2), -- Recon(x) = Filt(x) + floor((Recon(a) + Recon(b)) / 2) | FilterAverage -- | Filt(x) = Orig(x) - PaethPredictor(Orig(a), Orig(b), Orig(c)), -- Recon(x) = Filt(x) + PaethPredictor(Recon(a), Recon(b), Recon(c)) | FilterPaeth deriving (Enum, Show) -- | Different known interlace methods for PNG image data PngInterlaceMethod = -- | No interlacing, basic data ordering, line by line -- from left to right. PngNoInterlace -- | Use the Adam7 ordering, see `adam7Reordering` | PngInterlaceAdam7 deriving (Enum, Show) -------------------------------------------------- ---- Instances -------------------------------------------------- instance Binary PngFilter where put = putWord8 . toEnum . fromEnum get = getWord8 >>= \w -> case w of 0 -> return FilterNone 1 -> return FilterSub 2 -> return FilterUp 3 -> return FilterAverage 4 -> return FilterPaeth _ -> fail "Invalid scanline filter" instance Binary PngRawImage where put img = do putLazyByteString pngSignature put $ header img mapM_ put $ chunks img get = parseRawPngImage instance Binary PngRawChunk where put chunk = do putWord32be $ chunkLength chunk putLazyByteString $ chunkType chunk when (chunkLength chunk /= 0) (putLazyByteString $ chunkData chunk) putWord32be $ chunkCRC chunk get = do size <- getWord32be chunkSig <- getLazyByteString (fromIntegral $ L.length iHDRSignature) imgData <- if size == 0 then return L.empty else getLazyByteString (fromIntegral size) crc <- getWord32be let computedCrc = pngComputeCrc [chunkSig, imgData] when (computedCrc `xor` crc /= 0) (fail $ "Invalid CRC : " ++ show computedCrc ++ ", " ++ show crc) return PngRawChunk { chunkLength = size, chunkData = imgData, chunkCRC = crc, chunkType = chunkSig } instance Binary PngIHdr where put hdr = do putWord32be 13 let inner = runPut $ do putLazyByteString iHDRSignature putWord32be $ width hdr putWord32be $ height hdr putWord8 $ bitDepth hdr put $ colourType hdr put $ compressionMethod hdr put $ filterMethod hdr put $ interlaceMethod hdr crc = pngComputeCrc [inner] putLazyByteString inner putWord32be crc get = do _size <- getWord32be ihdrSig <- getLazyByteString (L.length iHDRSignature) when (ihdrSig /= iHDRSignature) (fail "Invalid PNG file, wrong ihdr") w <- getWord32be h <- getWord32be depth <- get colorType <- get compression <- get filtermethod <- get interlace <- get _crc <- getWord32be return PngIHdr { width = w, height = h, bitDepth = depth, colourType = colorType, compressionMethod = compression, filterMethod = filtermethod, interlaceMethod = interlace } -- | Parse method for a png chunk, without decompression. parseChunks :: Get [PngRawChunk] parseChunks = do chunk <- get if chunkType chunk == iENDSignature then return [chunk] else (chunk:) <$> parseChunks instance Binary PngInterlaceMethod where get = getWord8 >>= \w -> case w of 0 -> return PngNoInterlace 1 -> return PngInterlaceAdam7 _ -> fail "Invalid interlace method" put PngNoInterlace = putWord8 0 put PngInterlaceAdam7 = putWord8 1 -- | Implementation of the get method for the PngRawImage, -- unpack raw data, without decompressing it. parseRawPngImage :: Get PngRawImage parseRawPngImage = do sig <- getLazyByteString (L.length pngSignature) when (sig /= pngSignature) (fail "Invalid PNG file, signature broken") ihdr <- get chunkList <- parseChunks return PngRawImage { header = ihdr, chunks = chunkList } -------------------------------------------------- ---- functions -------------------------------------------------- -- | Signature signalling that the following data will be a png image -- in the png bit stream pngSignature :: ChunkSignature pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] -- | Helper function to help pack signatures. signature :: String -> ChunkSignature signature = LS.pack -- | Signature for the header chunk of png (must be the first) iHDRSignature :: ChunkSignature iHDRSignature = signature "IHDR" -- | Signature for a palette chunk in the pgn file. Must -- occure before iDAT. pLTESignature :: ChunkSignature pLTESignature = signature "PLTE" -- | Signature for a data chuck (with image parts in it) iDATSignature :: ChunkSignature iDATSignature = signature "IDAT" -- | Signature for the last chunk of a png image, telling -- the end. iENDSignature :: ChunkSignature iENDSignature = signature "IEND" tRNSSignature :: ChunkSignature tRNSSignature = signature "tRNS" gammaSignature :: ChunkSignature gammaSignature = signature "gAMA" pHYsSignature :: ChunkSignature pHYsSignature = signature "pHYs" tEXtSignature :: ChunkSignature tEXtSignature = signature "tEXt" zTXtSignature :: ChunkSignature zTXtSignature = signature "zTXt" animationControlSignature :: ChunkSignature animationControlSignature = signature "acTL" instance Binary PngImageType where put PngGreyscale = putWord8 0 put PngTrueColour = putWord8 2 put PngIndexedColor = putWord8 3 put PngGreyscaleWithAlpha = putWord8 4 put PngTrueColourWithAlpha = putWord8 6 get = get >>= imageTypeOfCode imageTypeOfCode :: Word8 -> Get PngImageType imageTypeOfCode 0 = return PngGreyscale imageTypeOfCode 2 = return PngTrueColour imageTypeOfCode 3 = return PngIndexedColor imageTypeOfCode 4 = return PngGreyscaleWithAlpha imageTypeOfCode 6 = return PngTrueColourWithAlpha imageTypeOfCode _ = fail "Invalid png color code" -- | From the Annex D of the png specification. pngCrcTable :: Vector Word32 pngCrcTable = fromListN 256 [ foldl' updateCrcConstant c [zero .. 7] | c <- [0 .. 255] ] where zero = 0 :: Int -- To avoid defaulting to Integer updateCrcConstant c _ | c .&. 1 /= 0 = magicConstant `xor` (c `unsafeShiftR` 1) | otherwise = c `unsafeShiftR` 1 magicConstant = 0xedb88320 :: Word32 -- | Compute the CRC of a raw buffer, as described in annex D of the PNG -- specification. pngComputeCrc :: [L.ByteString] -> Word32 pngComputeCrc = (0xFFFFFFFF `xor`) . L.foldl' updateCrc 0xFFFFFFFF . L.concat where updateCrc crc val = let u32Val = fromIntegral val lutVal = pngCrcTable ! (fromIntegral ((crc `xor` u32Val) .&. 0xFF)) in lutVal `xor` (crc `unsafeShiftR` 8) chunksWithSig :: PngRawImage -> ChunkSignature -> [LS.ByteString] chunksWithSig rawImg sig = [chunkData chunk | chunk <- chunks rawImg, chunkType chunk == sig] JuicyPixels-3.2.8/src/Codec/Picture/Png/Metadata.hs0000644000000000000000000001122112763010461020176 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Codec.Picture.Png.Metadata( extractMetadatas , encodeMetadatas ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>), (<*>), pure ) import Data.Monoid( Monoid, mempty ) import Data.Foldable( foldMap ) #endif import Data.Maybe( fromMaybe ) import Data.Binary( Binary( get, put ), encode ) import Data.Binary.Get( getLazyByteStringNul ) import Data.Binary.Put( putLazyByteString, putWord8 ) import qualified Data.ByteString.Lazy.Char8 as L import Data.Monoid( (<>) ) import Codec.Picture.InternalHelper import qualified Codec.Picture.Metadata as Met import Codec.Picture.Metadata ( Metadatas , dotsPerMeterToDotPerInch , Elem( (:=>) ) ) import Codec.Picture.Png.Type #if !MIN_VERSION_base(4,7,0) eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m eitherFoldMap f v = case v of Left _ -> mempty Right a -> f a #else eitherFoldMap :: Monoid m => (a -> m) -> Either e a -> m eitherFoldMap = foldMap #endif getGamma :: [L.ByteString] -> Metadatas getGamma [] = mempty getGamma (g:_) = eitherFoldMap unpackGamma $ runGet get g where unpackGamma gamma = Met.singleton Met.Gamma (getPngGamma gamma) getDpis :: [L.ByteString] -> Metadatas getDpis [] = mempty getDpis (b:_) = eitherFoldMap unpackPhys $ runGet get b where unpackPhys PngPhysicalDimension { pngUnit = PngUnitUnknown } = Met.insert Met.DpiX 72 $ Met.singleton Met.DpiY 72 unpackPhys phy@PngPhysicalDimension { pngUnit = PngUnitMeter } = Met.insert Met.DpiX dpx $ Met.singleton Met.DpiY dpy where dpx = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiX phy dpy = dotsPerMeterToDotPerInch . fromIntegral $ pngDpiY phy data PngText = PngText { pngKeyword :: !L.ByteString , pngData :: !L.ByteString } deriving Show instance Binary PngText where get = PngText <$> getLazyByteStringNul <*> getRemainingLazyBytes put (PngText kw pdata) = do putLazyByteString kw putWord8 0 putLazyByteString pdata textToMetadata :: PngText -> Metadatas textToMetadata ptext = case pngKeyword ptext of "Title" -> strValue Met.Title "Author" -> strValue Met.Author "Description" -> strValue Met.Description "Copyright" -> strValue Met.Copyright {-"Creation Time" -> strValue Creation-} "Software" -> strValue Met.Software "Disclaimer" -> strValue Met.Disclaimer "Warning" -> strValue Met.Warning "Source" -> strValue Met.Source "Comment" -> strValue Met.Comment other -> Met.singleton (Met.Unknown $ L.unpack other) (Met.String . L.unpack $ pngData ptext) where strValue k = Met.singleton k . L.unpack $ pngData ptext getTexts :: [L.ByteString] -> Metadatas getTexts = foldMap (eitherFoldMap textToMetadata . runGet get) where extractMetadatas :: PngRawImage -> Metadatas extractMetadatas img = getDpis (chunksOf pHYsSignature) <> getGamma (chunksOf gammaSignature) <> getTexts (chunksOf tEXtSignature) where chunksOf = chunksWithSig img encodePhysicalMetadata :: Metadatas -> [PngRawChunk] encodePhysicalMetadata metas = fromMaybe [] $ do dx <- Met.lookup Met.DpiX metas dy <- Met.lookup Met.DpiY metas let to = fromIntegral . Met.dotPerInchToDotsPerMeter dim = PngPhysicalDimension (to dx) (to dy) PngUnitMeter pure [mkRawChunk pHYsSignature $ encode dim] encodeSingleMetadata :: Metadatas -> [PngRawChunk] encodeSingleMetadata = Met.foldMap go where go :: Elem Met.Keys -> [PngRawChunk] go v = case v of Met.Exif _ :=> _ -> mempty Met.DpiX :=> _ -> mempty Met.DpiY :=> _ -> mempty Met.Width :=> _ -> mempty Met.Height :=> _ -> mempty Met.Format :=> _ -> mempty Met.Gamma :=> g -> pure $ mkRawChunk gammaSignature . encode $ PngGamma g Met.Title :=> tx -> txt "Title" (L.pack tx) Met.Description :=> tx -> txt "Description" (L.pack tx) Met.Author :=> tx -> txt "Author" (L.pack tx) Met.Copyright :=> tx -> txt "Copyright" (L.pack tx) Met.Software :=> tx -> txt "Software" (L.pack tx) Met.Comment :=> tx -> txt "Comment" (L.pack tx) Met.Disclaimer :=> tx -> txt "Disclaimer" (L.pack tx) Met.Source :=> tx -> txt "Source" (L.pack tx) Met.Warning :=> tx -> txt "Warning" (L.pack tx) Met.Unknown k :=> Met.String tx -> txt (L.pack k) (L.pack tx) Met.Unknown _ :=> _ -> mempty txt k c = pure . mkRawChunk tEXtSignature . encode $ PngText k c encodeMetadatas :: Metadatas -> [PngRawChunk] encodeMetadatas m = encodePhysicalMetadata m <> encodeSingleMetadata m JuicyPixels-3.2.8/src/Codec/Picture/Tiff/Metadata.hs0000644000000000000000000000721312763010461020350 0ustar0000000000000000{-# LANGUAGE CPP #-} module Codec.Picture.Tiff.Metadata( extractTiffMetadata ) where #if !MIN_VERSION_base(4,8,0) import Data.Monoid( mempty ) import Data.Foldable( foldMap ) import Control.Applicative( (<$>) ) #endif import Data.Foldable( find ) import qualified Data.Foldable as F import Data.Monoid( (<>) ) import Codec.Picture.Metadata( Metadatas ) import qualified Data.ByteString.Char8 as B import qualified Codec.Picture.Metadata as Met import Codec.Picture.Tiff.Types import Codec.Picture.Metadata.Exif extractTiffStringMetadata :: [ImageFileDirectory] -> Metadatas extractTiffStringMetadata = Met.insert Met.Format Met.SourceTiff . foldMap go where strMeta k = Met.singleton k . B.unpack exif ifd = Met.singleton (Met.Exif $ ifdIdentifier ifd) $ ifdExtended ifd inserter acc (k, v) = Met.insert (Met.Exif k) v acc go ifd = case (ifdIdentifier ifd, ifdExtended ifd) of (TagUnknown _, _) -> exif ifd (TagCopyright, ExifString v) -> strMeta Met.Copyright v (TagArtist, ExifString v) -> strMeta Met.Author v (TagDocumentName, ExifString v) -> strMeta Met.Title v (TagSoftware, ExifString v) -> strMeta Met.Software v (TagImageDescription, ExifString v) -> strMeta Met.Description v (TagCompression, _) -> mempty (TagImageWidth, _) -> Met.singleton Met.Width . fromIntegral $ ifdOffset ifd (TagImageLength, _) -> Met.singleton Met.Height . fromIntegral $ ifdOffset ifd (TagXResolution, _) -> mempty (TagYResolution, _) -> mempty (TagResolutionUnit, _) -> mempty (TagRowPerStrip, _) -> mempty (TagStripByteCounts, _) -> mempty (TagStripOffsets, _) -> mempty (TagBitsPerSample, _) -> mempty (TagColorMap, _) -> mempty (TagTileWidth, _) -> mempty (TagTileLength, _) -> mempty (TagTileOffset, _) -> mempty (TagTileByteCount, _) -> mempty (TagSamplesPerPixel, _) -> mempty (TagYCbCrCoeff, _) -> mempty (TagYCbCrSubsampling, _) -> mempty (TagYCbCrPositioning, _) -> mempty (TagJpegProc, _) -> mempty (TagJPEGInterchangeFormat, _) -> mempty (TagJPEGInterchangeFormatLength, _) -> mempty (TagJPEGRestartInterval, _) -> mempty (TagJPEGLosslessPredictors, _) -> mempty (TagJPEGPointTransforms, _) -> mempty (TagJPEGQTables, _) -> mempty (TagJPEGDCTables, _) -> mempty (TagJPEGACTables, _) -> mempty (TagExifOffset, ExifIFD lst) -> F.foldl' inserter mempty lst _ -> mempty byTag :: ExifTag -> ImageFileDirectory -> Bool byTag t ifd = ifdIdentifier ifd == t data TiffResolutionUnit = ResolutionUnitUnknown | ResolutionUnitInch | ResolutionUnitCentimeter unitOfIfd :: ImageFileDirectory -> TiffResolutionUnit unitOfIfd ifd = case (ifdType ifd, ifdOffset ifd) of (TypeShort, 1) -> ResolutionUnitUnknown (TypeShort, 2) -> ResolutionUnitInch (TypeShort, 3) -> ResolutionUnitCentimeter _ -> ResolutionUnitUnknown extractTiffDpiMetadata :: [ImageFileDirectory] -> Metadatas extractTiffDpiMetadata lst = go where go = case unitOfIfd <$> find (byTag TagResolutionUnit) lst of Nothing -> mempty Just ResolutionUnitUnknown -> mempty Just ResolutionUnitCentimeter -> findDpis Met.dotsPerCentiMeterToDotPerInch mempty Just ResolutionUnitInch -> findDpis id mempty findDpis toDpi = findDpi Met.DpiX TagXResolution toDpi . findDpi Met.DpiY TagYResolution toDpi findDpi k tag toDpi metas = case find (byTag tag) lst of Nothing -> metas Just ImageFileDirectory { ifdExtended = ExifRational num den } -> Met.insert k (toDpi . fromIntegral $ num `div` den) metas Just _ -> metas extractTiffMetadata :: [ImageFileDirectory] -> Metadatas extractTiffMetadata lst = extractTiffDpiMetadata lst <> extractTiffStringMetadata lst JuicyPixels-3.2.8/src/Codec/Picture/Tiff/Types.hs0000644000000000000000000003726612763010461017747 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} module Codec.Picture.Tiff.Types ( BinaryParam( .. ) , Endianness( .. ) , TiffHeader( .. ) , TiffPlanarConfiguration( .. ) , TiffCompression( .. ) , IfdType( .. ) , TiffColorspace( .. ) , TiffSampleFormat( .. ) , ImageFileDirectory( .. ) , ExtraSample( .. ) , Predictor( .. ) , planarConfgOfConstant , constantToPlaneConfiguration , unpackSampleFormat , word16OfTag , unpackPhotometricInterpretation , packPhotometricInterpretation , codeOfExtraSample , unPackCompression , packCompression , predictorOfConstant ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<$>), (<*>), pure ) #endif import Control.Monad( when, replicateM, ) import Data.Bits( (.&.), unsafeShiftR ) import Data.Binary( Binary( .. ) ) import Data.Binary.Get( Get , getWord16le, getWord16be , getWord32le, getWord32be , bytesRead , skip , getByteString ) import Data.Binary.Put( Put , putWord16le, putWord16be , putWord32le, putWord32be , putByteString ) import Data.Function( on ) import Data.List( sortBy, mapAccumL ) import qualified Data.Vector as V import qualified Data.ByteString as B import Data.Int( Int32 ) import Data.Word( Word16, Word32 ) import Codec.Picture.Metadata.Exif {-import Debug.Trace-} data Endianness = EndianLittle | EndianBig deriving (Eq, Show) instance Binary Endianness where put EndianLittle = putWord16le 0x4949 put EndianBig = putWord16le 0x4D4D get = do tag <- getWord16le case tag of 0x4949 -> return EndianLittle 0x4D4D -> return EndianBig _ -> fail "Invalid endian tag value" -- | Because having a polymorphic get with endianness is to nice -- to pass on, introducing this helper type class, which is just -- a superset of Binary, but formalising a parameter passing -- into it. class BinaryParam a b where getP :: a -> Get b putP :: a -> b -> Put data TiffHeader = TiffHeader { hdrEndianness :: !Endianness , hdrOffset :: {-# UNPACK #-} !Word32 } deriving (Eq, Show) instance BinaryParam Endianness Word16 where putP EndianLittle = putWord16le putP EndianBig = putWord16be getP EndianLittle = getWord16le getP EndianBig = getWord16be instance BinaryParam Endianness Int32 where putP en v = putP en $ (fromIntegral v :: Word32) getP en = fromIntegral <$> (getP en :: Get Word32) instance BinaryParam Endianness Word32 where putP EndianLittle = putWord32le putP EndianBig = putWord32be getP EndianLittle = getWord32le getP EndianBig = getWord32be instance Binary TiffHeader where put hdr = do let endian = hdrEndianness hdr put endian putP endian (42 :: Word16) putP endian $ hdrOffset hdr get = do endian <- get magic <- getP endian let magicValue = 42 :: Word16 when (magic /= magicValue) (fail "Invalid TIFF magic number") TiffHeader endian <$> getP endian data TiffPlanarConfiguration = PlanarConfigContig -- = 1 | PlanarConfigSeparate -- = 2 planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration planarConfgOfConstant 0 = pure PlanarConfigContig planarConfgOfConstant 1 = pure PlanarConfigContig planarConfgOfConstant 2 = pure PlanarConfigSeparate planarConfgOfConstant v = fail $ "Unknown planar constant (" ++ show v ++ ")" constantToPlaneConfiguration :: TiffPlanarConfiguration -> Word16 constantToPlaneConfiguration PlanarConfigContig = 1 constantToPlaneConfiguration PlanarConfigSeparate = 2 data TiffCompression = CompressionNone -- 1 | CompressionModifiedRLE -- 2 | CompressionLZW -- 5 | CompressionJPEG -- 6 | CompressionPackBit -- 32273 data IfdType = TypeByte | TypeAscii | TypeShort | TypeLong | TypeRational | TypeSByte | TypeUndefined | TypeSignedShort | TypeSignedLong | TypeSignedRational | TypeFloat | TypeDouble deriving Show instance BinaryParam Endianness IfdType where getP endianness = getP endianness >>= conv where conv :: Word16 -> Get IfdType conv v = case v of 1 -> return TypeByte 2 -> return TypeAscii 3 -> return TypeShort 4 -> return TypeLong 5 -> return TypeRational 6 -> return TypeSByte 7 -> return TypeUndefined 8 -> return TypeSignedShort 9 -> return TypeSignedLong 10 -> return TypeSignedRational 11 -> return TypeFloat 12 -> return TypeDouble _ -> fail "Invalid TIF directory type" putP endianness = putP endianness . conv where conv :: IfdType -> Word16 conv v = case v of TypeByte -> 1 TypeAscii -> 2 TypeShort -> 3 TypeLong -> 4 TypeRational -> 5 TypeSByte -> 6 TypeUndefined -> 7 TypeSignedShort -> 8 TypeSignedLong -> 9 TypeSignedRational -> 10 TypeFloat -> 11 TypeDouble -> 12 instance BinaryParam Endianness ExifTag where getP endianness = tagOfWord16 <$> getP endianness putP endianness = putP endianness . word16OfTag data Predictor = PredictorNone -- 1 | PredictorHorizontalDifferencing -- 2 deriving Eq predictorOfConstant :: Word32 -> Get Predictor predictorOfConstant 1 = pure PredictorNone predictorOfConstant 2 = pure PredictorHorizontalDifferencing predictorOfConstant v = fail $ "Unknown predictor (" ++ show v ++ ")" instance BinaryParam (Endianness, Int, ImageFileDirectory) ExifData where putP (endianness, _, _) = dump where dump ExifNone = pure () dump (ExifLong _) = pure () dump (ExifShort _) = pure () dump (ExifIFD _) = pure () dump (ExifString bstr) = putByteString bstr dump (ExifUndefined bstr) = putByteString bstr -- wrong if length == 2 dump (ExifShorts shorts) = V.mapM_ (putP endianness) shorts dump (ExifLongs longs) = V.mapM_ (putP endianness) longs dump (ExifRational a b) = putP endianness a >> putP endianness b dump (ExifSignedRational a b) = putP endianness a >> putP endianness b getP (endianness, maxi, ifd) = fetcher ifd where align ImageFileDirectory { ifdOffset = offset } act = do readed <- bytesRead let delta = fromIntegral offset - readed if offset >= fromIntegral maxi || fromIntegral readed > offset then pure ExifNone else do skip $ fromIntegral delta act getE :: (BinaryParam Endianness a) => Get a getE = getP endianness getVec count = V.replicateM (fromIntegral count) fetcher ImageFileDirectory { ifdIdentifier = TagExifOffset , ifdType = TypeLong , ifdCount = 1 } = do align ifd $ do let byOffset = sortBy (compare `on` ifdOffset) cleansIfds = fmap (cleanImageFileDirectory endianness) subIfds <- cleansIfds . byOffset <$> getP endianness cleaned <- fetchExtended endianness maxi $ sortBy (compare `on` ifdOffset) subIfds pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] {- fetcher ImageFileDirectory { ifdIdentifier = TagGPSInfo , ifdType = TypeLong , ifdCount = 1 } = do align ifd subIfds <- fmap (cleanImageFileDirectory endianness) <$> getP endianness cleaned <- fetchExtended endianness subIfds pure $ ExifIFD [(ifdIdentifier fd, ifdExtended fd) | fd <- cleaned] -} fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdCount = count } | count > 4 = align ifd $ ExifUndefined <$> getByteString (fromIntegral count) fetcher ImageFileDirectory { ifdType = TypeUndefined, ifdOffset = ofs } = pure . ExifUndefined . B.pack $ take (fromIntegral $ ifdCount ifd) [fromIntegral $ ofs .&. 0xFF000000 `unsafeShiftR` (3 * 8) ,fromIntegral $ ofs .&. 0x00FF0000 `unsafeShiftR` (2 * 8) ,fromIntegral $ ofs .&. 0x0000FF00 `unsafeShiftR` (1 * 8) ,fromIntegral $ ofs .&. 0x000000FF ] fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = align ifd $ ExifString <$> getByteString (fromIntegral count) fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = pure . ExifShorts $ V.fromListN 2 valList where high = fromIntegral $ ofs `unsafeShiftR` 16 low = fromIntegral $ ofs .&. 0xFFFF valList = case endianness of EndianLittle -> [low, high] EndianBig -> [high, low] fetcher ImageFileDirectory { ifdType = TypeRational, ifdCount = 1 } = do align ifd $ ExifRational <$> getP EndianLittle <*> getP EndianLittle fetcher ImageFileDirectory { ifdType = TypeSignedRational, ifdCount = 1 } = do align ifd $ ExifSignedRational <$> getP EndianLittle <*> getP EndianLittle fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 1 } = pure . ExifShort . fromIntegral $ ifdOffset ifd fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = align ifd $ ExifShorts <$> getVec count getE fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = 1 } = pure . ExifLong . fromIntegral $ ifdOffset ifd fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = align ifd $ ExifLongs <$> getVec count getE fetcher _ = pure ExifNone cleanImageFileDirectory :: Endianness -> ImageFileDirectory -> ImageFileDirectory cleanImageFileDirectory EndianBig ifd@(ImageFileDirectory { ifdCount = 1 }) = aux $ ifdType ifd where aux TypeShort = ifd { ifdOffset = ifdOffset ifd `unsafeShiftR` 16 } aux _ = ifd cleanImageFileDirectory _ ifd = ifd fetchExtended :: Endianness -> Int -> [ImageFileDirectory] -> Get [ImageFileDirectory] fetchExtended endian maxi = mapM $ \ifd -> do v <- getP (endian, maxi, ifd) pure $ ifd { ifdExtended = v } -- | All the IFD must be written in order according to the tag -- value of the IFD. To avoid getting to much restriction in the -- serialization code, just sort it. orderIfdByTag :: [ImageFileDirectory] -> [ImageFileDirectory] orderIfdByTag = sortBy comparer where comparer a b = compare t1 t2 where t1 = word16OfTag $ ifdIdentifier a t2 = word16OfTag $ ifdIdentifier b -- | Given an official offset and a list of IFD, update the offset information -- of the IFD with extended data. setupIfdOffsets :: Word32 -> [ImageFileDirectory] -> [ImageFileDirectory] setupIfdOffsets initialOffset lst = snd $ mapAccumL updater startExtended lst where ifdElementCount = fromIntegral $ length lst ifdSize = 12 ifdCountSize = 2 nextOffsetSize = 4 startExtended = initialOffset + ifdElementCount * ifdSize + ifdCountSize + nextOffsetSize updater ix ifd@(ImageFileDirectory { ifdExtended = ExifString b }) = (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) updater ix ifd@(ImageFileDirectory { ifdExtended = ExifLongs v }) | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) , ifd { ifdOffset = ix } ) updater ix ifd@(ImageFileDirectory { ifdExtended = ExifShorts v }) | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) , ifd { ifdOffset = ix }) updater ix ifd = (ix, ifd) instance BinaryParam B.ByteString (TiffHeader, [ImageFileDirectory]) where putP rawData (hdr, ifds) = do put hdr putByteString rawData let endianness = hdrEndianness hdr list = setupIfdOffsets (hdrOffset hdr) $ orderIfdByTag ifds putP endianness list mapM_ (\ifd -> putP (endianness, (0::Int), ifd) $ ifdExtended ifd) list getP raw = do hdr <- get readed <- bytesRead skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed let endian = hdrEndianness hdr byOffset = sortBy (compare `on` ifdOffset) cleanIfds = fmap (cleanImageFileDirectory endian) ifd <- cleanIfds . byOffset <$> getP endian cleaned <- fetchExtended endian (B.length raw) ifd return (hdr, cleaned) data TiffSampleFormat = TiffSampleUint | TiffSampleInt | TiffSampleDouble | TiffSampleUnknown deriving Eq unpackSampleFormat :: Word32 -> Get TiffSampleFormat unpackSampleFormat v = case v of 1 -> pure TiffSampleUint 2 -> pure TiffSampleInt 3 -> pure TiffSampleDouble 4 -> pure TiffSampleUnknown vv -> fail $ "Undefined data format (" ++ show vv ++ ")" data ImageFileDirectory = ImageFileDirectory { ifdIdentifier :: !ExifTag , ifdType :: !IfdType , ifdCount :: !Word32 , ifdOffset :: !Word32 , ifdExtended :: !ExifData } deriving Show instance BinaryParam Endianness ImageFileDirectory where getP endianness = ImageFileDirectory <$> getE <*> getE <*> getE <*> getE <*> pure ExifNone where getE :: (BinaryParam Endianness a) => Get a getE = getP endianness putP endianness ifd =do let putE :: (BinaryParam Endianness a) => a -> Put putE = putP endianness putE $ ifdIdentifier ifd putE $ ifdType ifd putE $ ifdCount ifd putE $ ifdOffset ifd instance BinaryParam Endianness [ImageFileDirectory] where getP endianness = do count <- getP endianness :: Get Word16 rez <- replicateM (fromIntegral count) $ getP endianness _ <- getP endianness :: Get Word32 pure rez putP endianness lst = do let count = fromIntegral $ length lst :: Word16 putP endianness count mapM_ (putP endianness) lst putP endianness (0 :: Word32) data TiffColorspace = TiffMonochromeWhite0 -- ^ 0 | TiffMonochrome -- ^ 1 | TiffRGB -- ^ 2 | TiffPaleted -- ^ 3 | TiffTransparencyMask -- ^ 4 | TiffCMYK -- ^ 5 | TiffYCbCr -- ^ 6 | TiffCIELab -- ^ 8 packPhotometricInterpretation :: TiffColorspace -> Word16 packPhotometricInterpretation v = case v of TiffMonochromeWhite0 -> 0 TiffMonochrome -> 1 TiffRGB -> 2 TiffPaleted -> 3 TiffTransparencyMask -> 4 TiffCMYK -> 5 TiffYCbCr -> 6 TiffCIELab -> 8 unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace unpackPhotometricInterpretation v = case v of 0 -> pure TiffMonochromeWhite0 1 -> pure TiffMonochrome 2 -> pure TiffRGB 3 -> pure TiffPaleted 4 -> pure TiffTransparencyMask 5 -> pure TiffCMYK 6 -> pure TiffYCbCr 8 -> pure TiffCIELab vv -> fail $ "Unrecognized color space " ++ show vv data ExtraSample = ExtraSampleUnspecified -- ^ 0 | ExtraSampleAssociatedAlpha -- ^ 1 | ExtraSampleUnassociatedAlpha -- ^ 2 codeOfExtraSample :: ExtraSample -> Word16 codeOfExtraSample v = case v of ExtraSampleUnspecified -> 0 ExtraSampleAssociatedAlpha -> 1 ExtraSampleUnassociatedAlpha -> 2 unPackCompression :: Word32 -> Get TiffCompression unPackCompression v = case v of 0 -> pure CompressionNone 1 -> pure CompressionNone 2 -> pure CompressionModifiedRLE 5 -> pure CompressionLZW 6 -> pure CompressionJPEG 32773 -> pure CompressionPackBit vv -> fail $ "Unknown compression scheme " ++ show vv packCompression :: TiffCompression -> Word16 packCompression v = case v of CompressionNone -> 1 CompressionModifiedRLE -> 2 CompressionLZW -> 5 CompressionJPEG -> 6 CompressionPackBit -> 32773 JuicyPixels-3.2.8/src/Codec/Picture/BitWriter.hs0000644000000000000000000003074712763010461017663 0ustar0000000000000000{-# LANGUAGE Rank2Types #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} -- | This module implement helper functions to read & write data -- at bits level. module Codec.Picture.BitWriter( BoolReader , emptyBoolState , BoolState , byteAlignJpg , getNextBitsLSBFirst , getNextBitsMSBFirst , getNextBitJpg , getNextIntJpg , setDecodedString , setDecodedStringMSB , setDecodedStringJpg , runBoolReader , BoolWriteStateRef , newWriteStateRef , finalizeBoolWriter , writeBits' , writeBitsGif , initBoolState , initBoolStateJpg , execBoolReader , runBoolReaderWith ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative( (<*>), (<$>) ) #endif import Data.STRef import Control.Monad( when ) import Control.Monad.ST( ST ) import qualified Control.Monad.Trans.State.Strict as S import Data.Int ( Int32 ) import Data.Word( Word8, Word32 ) import Data.Bits( (.&.), (.|.), unsafeShiftR, unsafeShiftL ) import Codec.Picture.VectorByteConversion( blitVector ) import qualified Data.Vector.Storable.Mutable as M import qualified Data.Vector.Storable as VS import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L -------------------------------------------------- ---- Reader -------------------------------------------------- -- | Current bit index, current value, string data BoolState = BoolState {-# UNPACK #-} !Int {-# UNPACK #-} !Word8 !B.ByteString emptyBoolState :: BoolState emptyBoolState = BoolState (-1) 0 B.empty -- | Type used to read bits type BoolReader s a = S.StateT BoolState (ST s) a runBoolReader :: BoolReader s a -> ST s a runBoolReader action = S.evalStateT action $ BoolState 0 0 B.empty runBoolReaderWith :: BoolState -> BoolReader s a -> ST s (a, BoolState) runBoolReaderWith st action = S.runStateT action st execBoolReader :: BoolState -> BoolReader s a -> ST s BoolState execBoolReader st reader = S.execStateT reader st initBoolState :: B.ByteString -> BoolState initBoolState str = case B.uncons str of Nothing -> BoolState 0 0 B.empty Just (v, rest) -> BoolState 0 v rest initBoolStateJpg :: B.ByteString -> BoolState initBoolStateJpg str = case B.uncons str of Nothing -> BoolState 0 0 B.empty Just (0xFF, rest) -> case B.uncons rest of Nothing -> BoolState 7 0 B.empty Just (0x00, afterMarker) -> BoolState 7 0xFF afterMarker Just (_ , afterMarker) -> initBoolStateJpg afterMarker Just (v, rest) -> BoolState 7 v rest -- | Bitify a list of things to decode. setDecodedString :: B.ByteString -> BoolReader s () setDecodedString str = case B.uncons str of Nothing -> S.put $ BoolState 0 0 B.empty Just (v, rest) -> S.put $ BoolState 0 v rest -- | Drop all bit until the bit of indice 0, usefull to parse restart -- marker, as they are byte aligned, but Huffman might not. byteAlignJpg :: BoolReader s () byteAlignJpg = do BoolState idx _ chain <- S.get when (idx /= 7) (setDecodedStringJpg chain) getNextBitJpg :: BoolReader s Bool {-# INLINE getNextBitJpg #-} getNextBitJpg = do BoolState idx v chain <- S.get let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 if idx == 0 then setDecodedStringJpg chain else S.put $ BoolState (idx - 1) v chain return val getNextIntJpg :: Int -> BoolReader s Int32 {-# INLINE getNextIntJpg #-} getNextIntJpg = go 0 where go !acc !0 = return acc go !acc !n = do BoolState idx v chain <- S.get let !leftBits = 1 + fromIntegral idx if n >= leftBits then do setDecodedStringJpg chain let !remaining = n - leftBits !mask = (1 `unsafeShiftL` leftBits) - 1 !finalV = fromIntegral v .&. mask !theseBits = finalV `unsafeShiftL` remaining go (acc .|. theseBits) remaining else do let !remaining = leftBits - n !mask = (1 `unsafeShiftL` n) - 1 !finalV = fromIntegral v `unsafeShiftR` remaining S.put $ BoolState (fromIntegral remaining - 1) v chain return $ (finalV .&. mask) .|. acc setDecodedStringMSB :: B.ByteString -> BoolReader s () setDecodedStringMSB str = case B.uncons str of Nothing -> S.put $ BoolState 8 0 B.empty Just (v, rest) -> S.put $ BoolState 8 v rest {-# INLINE getNextBitsMSBFirst #-} getNextBitsMSBFirst :: Int -> BoolReader s Word32 getNextBitsMSBFirst requested = go 0 requested where go :: Word32 -> Int -> BoolReader s Word32 go !acc !0 = return acc go !acc !n = do BoolState idx v chain <- S.get let !leftBits = fromIntegral idx if n >= leftBits then do setDecodedStringMSB chain let !theseBits = fromIntegral v `unsafeShiftL` (n - leftBits) go (acc .|. theseBits) (n - leftBits) else do let !remaining = leftBits - n !mask = (1 `unsafeShiftL` remaining) - 1 S.put $ BoolState (fromIntegral remaining) (v .&. mask) chain return $ (fromIntegral v `unsafeShiftR` remaining) .|. acc {-# INLINE getNextBitsLSBFirst #-} getNextBitsLSBFirst :: Int -> BoolReader s Word32 getNextBitsLSBFirst count = aux 0 count where aux acc 0 = return acc aux acc n = do bit <- getNextBit let nextVal | bit = acc .|. (1 `unsafeShiftL` (count - n)) | otherwise = acc aux nextVal (n - 1) {-# INLINE getNextBit #-} getNextBit :: BoolReader s Bool getNextBit = do BoolState idx v chain <- S.get let val = (v .&. (1 `unsafeShiftL` idx)) /= 0 if idx == 7 then setDecodedString chain else S.put $ BoolState (idx + 1) v chain return val -- | Bitify a list of things to decode. Handle Jpeg escape -- code (0xFF 0x00), thus should be only used in JPEG decoding. setDecodedStringJpg :: B.ByteString -> BoolReader s () setDecodedStringJpg str = case B.uncons str of Nothing -> S.put $ BoolState 7 0 B.empty Just (0xFF, rest) -> case B.uncons rest of Nothing -> S.put $ BoolState 7 0 B.empty Just (0x00, afterMarker) -> -- trace "00" $ S.put $ BoolState 7 0xFF afterMarker Just (_ , afterMarker) -> setDecodedStringJpg afterMarker Just (v, rest) -> S.put $ BoolState 7 v rest -------------------------------------------------- ---- Writer -------------------------------------------------- defaultBufferSize :: Int defaultBufferSize = 256 * 1024 data BoolWriteStateRef s = BoolWriteStateRef { bwsCurrBuffer :: STRef s (M.MVector s Word8) , bwsBufferList :: STRef s [B.ByteString] , bwsWrittenWords :: STRef s Int , bwsBitAcc :: STRef s Word8 , bwsBitReaded :: STRef s Int } newWriteStateRef :: ST s (BoolWriteStateRef s) newWriteStateRef = do origMv <- M.new defaultBufferSize BoolWriteStateRef <$> newSTRef origMv <*> newSTRef [] <*> newSTRef 0 <*> newSTRef 0 <*> newSTRef 0 finalizeBoolWriter :: BoolWriteStateRef s -> ST s L.ByteString finalizeBoolWriter st = do forceBufferFlushing' st L.fromChunks <$> readSTRef (bwsBufferList st) forceBufferFlushing' :: BoolWriteStateRef s -> ST s () forceBufferFlushing' (BoolWriteStateRef { bwsCurrBuffer = vecRef , bwsWrittenWords = countRef , bwsBufferList = lstRef }) = do vec <- readSTRef vecRef count <- readSTRef countRef lst <- readSTRef lstRef nmv <- M.new defaultBufferSize str <- byteStringFromVector vec count writeSTRef vecRef nmv writeSTRef lstRef $ lst ++ [str] writeSTRef countRef 0 flushCurrentBuffer' :: BoolWriteStateRef s -> ST s () flushCurrentBuffer' st = do count <- readSTRef $ bwsWrittenWords st when (count >= defaultBufferSize) (forceBufferFlushing' st) byteStringFromVector :: M.MVector s Word8 -> Int -> ST s B.ByteString byteStringFromVector vec size = do frozen <- VS.unsafeFreeze vec return $ blitVector frozen 0 size setBitCount' :: BoolWriteStateRef s -> Word8 -> Int -> ST s () {-# INLINE setBitCount' #-} setBitCount' st acc count = do writeSTRef (bwsBitAcc st) acc writeSTRef (bwsBitReaded st) count resetBitCount' :: BoolWriteStateRef s -> ST s () {-# INLINE resetBitCount' #-} resetBitCount' st = setBitCount' st 0 0 pushByte' :: BoolWriteStateRef s -> Word8 -> ST s () {-# INLINE pushByte' #-} pushByte' st v = do flushCurrentBuffer' st idx <- readSTRef (bwsWrittenWords st) vec <- readSTRef (bwsCurrBuffer st) M.write vec idx v writeSTRef (bwsWrittenWords st) $ idx + 1 -- | Append some data bits to a Put monad. writeBits' :: BoolWriteStateRef s -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB -> Int -- ^ Number of bit to write from 1 to 32 -> ST s () {-# INLINE writeBits' #-} writeBits' st d c = do currWord <- readSTRef $ bwsBitAcc st currCount <- readSTRef $ bwsBitReaded st serialize d c currWord currCount where dumpByte 0xFF = pushByte' st 0xFF >> pushByte' st 0x00 dumpByte i = pushByte' st i serialize bitData bitCount currentWord count | bitCount + count == 8 = do resetBitCount' st dumpByte (fromIntegral $ (currentWord `unsafeShiftL` bitCount) .|. fromIntegral cleanData) | bitCount + count < 8 = let newVal = currentWord `unsafeShiftL` bitCount in setBitCount' st (newVal .|. fromIntegral cleanData) $ count + bitCount | otherwise = let leftBitCount = 8 - count :: Int highPart = cleanData `unsafeShiftR` (bitCount - leftBitCount) :: Word32 prevPart = fromIntegral currentWord `unsafeShiftL` leftBitCount :: Word32 nextMask = (1 `unsafeShiftL` (bitCount - leftBitCount)) - 1 :: Word32 newData = cleanData .&. nextMask :: Word32 newCount = bitCount - leftBitCount :: Int toWrite = fromIntegral $ prevPart .|. highPart :: Word8 in dumpByte toWrite >> serialize newData newCount 0 0 where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 cleanData = bitData .&. cleanMask :: Word32 -- | Append some data bits to a Put monad. writeBitsGif :: BoolWriteStateRef s -> Word32 -- ^ The real data to be stored. Actual data should be in the LSB -> Int -- ^ Number of bit to write from 1 to 32 -> ST s () {-# INLINE writeBitsGif #-} writeBitsGif st d c = do currWord <- readSTRef $ bwsBitAcc st currCount <- readSTRef $ bwsBitReaded st serialize d c currWord currCount where dumpByte = pushByte' st serialize bitData bitCount currentWord count | bitCount + count == 8 = do resetBitCount' st dumpByte (fromIntegral $ currentWord .|. (fromIntegral cleanData `unsafeShiftL` count)) | bitCount + count < 8 = let newVal = fromIntegral cleanData `unsafeShiftL` count in setBitCount' st (newVal .|. currentWord) $ count + bitCount | otherwise = let leftBitCount = 8 - count :: Int newData = cleanData `unsafeShiftR` leftBitCount :: Word32 newCount = bitCount - leftBitCount :: Int toWrite = fromIntegral $ fromIntegral currentWord .|. (cleanData `unsafeShiftL` count) :: Word8 in dumpByte toWrite >> serialize newData newCount 0 0 where cleanMask = (1 `unsafeShiftL` bitCount) - 1 :: Word32 cleanData = bitData .&. cleanMask :: Word32 {-# ANN module "HLint: ignore Reduce duplication" #-} JuicyPixels-3.2.8/src/Codec/Picture/InternalHelper.hs0000644000000000000000000000313012763010461020646 0ustar0000000000000000{-# LANGUAGE CPP #-} module Codec.Picture.InternalHelper ( runGet , runGetStrict , decode , getRemainingBytes , getRemainingLazyBytes ) where import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import Data.Binary( Binary( get ) ) import Data.Binary.Get( Get , getRemainingLazyByteString ) import qualified Data.Binary.Get as G #if MIN_VERSION_binary(0,6,4) #else import Control.Applicative( (<$>) ) import qualified Control.Exception as E -- I feel so dirty. :( import System.IO.Unsafe( unsafePerformIO ) #endif decode :: (Binary a) => B.ByteString -> Either String a decode = runGetStrict get runGet :: Get a -> L.ByteString -> Either String a #if MIN_VERSION_binary(0,6,4) runGet act = unpack . G.runGetOrFail act where unpack (Left (_, _, str)) = Left str unpack (Right (_, _, element)) = Right element #else runGet act str = unsafePerformIO $ E.catch (Right <$> E.evaluate (G.runGet act str)) (\msg -> return . Left $ show (msg :: E.SomeException)) #endif runGetStrict :: Get a -> B.ByteString -> Either String a runGetStrict act buffer = runGet act $ L.fromChunks [buffer] getRemainingBytes :: Get B.ByteString getRemainingBytes = do rest <- getRemainingLazyByteString return $ case L.toChunks rest of [] -> B.empty [a] -> a lst -> B.concat lst getRemainingLazyBytes :: Get L.ByteString getRemainingLazyBytes = getRemainingLazyByteString JuicyPixels-3.2.8/src/Codec/Picture/VectorByteConversion.hs0000644000000000000000000000323212763010461022071 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE CPP #-} module Codec.Picture.VectorByteConversion( blitVector , toByteString , imageFromUnsafePtr ) where import Data.Word( Word8 ) import Data.Vector.Storable( Vector, unsafeToForeignPtr, unsafeFromForeignPtr0 ) import Foreign.Storable( Storable, sizeOf ) #if !MIN_VERSION_base(4,8,0) import Foreign.ForeignPtr.Safe( ForeignPtr, castForeignPtr ) #else import Foreign.ForeignPtr( ForeignPtr, castForeignPtr ) #endif import qualified Data.ByteString as B import qualified Data.ByteString.Internal as S import Codec.Picture.Types blitVector :: Vector Word8 -> Int -> Int -> B.ByteString blitVector vec atIndex = S.PS ptr (offset + atIndex) where (ptr, offset, _length) = unsafeToForeignPtr vec toByteString :: forall a. (Storable a) => Vector a -> B.ByteString toByteString vec = S.PS (castForeignPtr ptr) offset (len * size) where (ptr, offset, len) = unsafeToForeignPtr vec size = sizeOf (undefined :: a) -- | Import a image from an unsafe pointer -- The pointer must have a size of width * height * componentCount px imageFromUnsafePtr :: forall px . (Pixel px, (PixelBaseComponent px) ~ Word8) => Int -- ^ Width in pixels -> Int -- ^ Height in pixels -> ForeignPtr Word8 -- ^ Pointer to the raw data -> Image px imageFromUnsafePtr width height ptr = Image width height $ unsafeFromForeignPtr0 ptr size where compCount = componentCount (undefined :: px) size = width * height * compCount JuicyPixels-3.2.8/docimages/juicy.png0000644000000000000000000000050212303212747015744 0ustar0000000000000000‰PNG  IHDRÀÀ òq4PLTEI¨4“XBÿ«&ÿÿÿGÿQ“tRNS@æØfÞIDATx^ìÖÁ €PÄP[°{Úþ[V?ÿ\ pixelGraphic PixelRGB8 PixelRGB8 PixelRGBA8 PixelRGBA8 PixelRGB8->PixelRGBA8 promotePixel PixelRGBF PixelRGBF PixelRGB8->PixelRGBF promotePixel Pixel8 Pixel8 PixelRGB8->Pixel8 computeLuma PixelCMYK8 PixelCMYK8 PixelRGB8->PixelCMYK8 convertPixel PixelYCbCr8 PixelYCbCr8 PixelRGB8->PixelYCbCr8 convertPixel PixelRGB16 PixelRGB16 PixelRGBA16 PixelRGBA16 PixelRGB16->PixelRGBA16 promotePixel Pixel16 Pixel16 PixelRGB16->Pixel16 computeLuma PixelCMYK16 PixelCMYK16 PixelRGB16->PixelCMYK16 convertPixel PixelRGBA16->PixelRGB16 dropTransparency PixelRGBA8->PixelRGB8 dropTransparency PixelRGBA8->Pixel8 computeLuma PixelF PixelF PixelRGBF->PixelF computeLuma PixelYA16 PixelYA16 PixelYA16->PixelRGBA16 promotePixel PixelYA16->Pixel16 dropTransparency PixelYA8 PixelYA8 PixelYA8->PixelRGB8 promotePixel PixelYA8->PixelRGBA8 promotePixel PixelYA8->Pixel8 dropTransparency PixelYA8->Pixel8 computeLuma PixelF->PixelRGBF promotePixel Pixel16->PixelRGB16 promotePixel Pixel16->PixelRGBA16 promotePixel Pixel16->PixelYA16 promotePixel Pixel8->PixelRGB8 promotePixel Pixel8->PixelRGBA8 promotePixel Pixel8->PixelYA8 promotePixel Pixel8->PixelF promotePixel Pixel8->Pixel16 promotePixel PixelCMYK16->PixelRGB16 convertPixel PixelCMYK8->PixelRGB8 convertPixel PixelYCbCr8->PixelRGB8 convertPixel PixelYCbCr8->Pixel8 computeLuma JuicyPixels-3.2.8/LICENSE0000644000000000000000000000302712027033337013171 0ustar0000000000000000Copyright (c)2011, Vincent Berthoux All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Vincent Berthoux nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. JuicyPixels-3.2.8/src/Codec/Picture/ConvGraph.hs0000644000000000000000000000031212763010461017620 0ustar0000000000000000-- $graph -- -- The following graph describe the differents way to convert between pixel types, -- -- * Nodes describe pixel type -- -- * Arrows describe functions -- -- <> -- JuicyPixels-3.2.8/Setup.hs0000644000000000000000000000006012227041203013603 0ustar0000000000000000import Distribution.Simple main = defaultMain JuicyPixels-3.2.8/JuicyPixels.cabal0000644000000000000000000000724512763046173015437 0ustar0000000000000000Name: JuicyPixels Version: 3.2.8 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> . This library can load and store images in PNG,Bitmap, Jpeg, Radiance, Tiff and Gif images. homepage: https://github.com/Twinside/Juicy.Pixels License: BSD3 License-file: LICENSE Author: Vincent Berthoux Maintainer: vincent.berthoux@gmail.com Category: Codec, Graphics, Image Stability: Stable Build-type: Simple -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.10 extra-source-files: changelog, docimages/*.png, docimages/*.svg, README.md extra-doc-files: docimages/*.png, docimages/*.svg Source-Repository head Type: git Location: git://github.com/Twinside/Juicy.Pixels.git Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git Tag: v3.2.8 Flag Mmap Description: Enable the file loading via mmap (memory map) Default: False Library hs-source-dirs: src Default-Language: Haskell2010 Exposed-modules: Codec.Picture, Codec.Picture.Bitmap, Codec.Picture.Gif, Codec.Picture.Png, Codec.Picture.Jpg, Codec.Picture.HDR, Codec.Picture.Tga, Codec.Picture.Tiff, Codec.Picture.Metadata, Codec.Picture.Metadata.Exif, Codec.Picture.Saving, Codec.Picture.Types, Codec.Picture.ColorQuant Ghc-options: -O3 -Wall Build-depends: base >= 4.5 && < 5, bytestring >= 0.9 && < 0.11, mtl >= 1.1 && < 2.3, binary >= 0.5 && < 0.9, zlib >= 0.5.3.1 && < 0.7, transformers >= 0.2, vector >= 0.10 && < 0.12, primitive >= 0.4 && < 0.7, deepseq >= 1.1 && < 1.5, containers >= 0.4.2 && < 0.6 if flag(Mmap) Build-depends: mmap CC-Options: "-DWITH_MMAP_BYTESTRING" -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable, Codec.Picture.Jpg.Metadata, Codec.Picture.Jpg.FastIdct, Codec.Picture.Jpg.FastDct, Codec.Picture.Jpg.Types, Codec.Picture.Jpg.Common, Codec.Picture.Jpg.Progressive, Codec.Picture.Gif.LZW, Codec.Picture.Gif.LZWEncoding, Codec.Picture.Png.Export, Codec.Picture.Png.Type, Codec.Picture.Png.Metadata, Codec.Picture.Tiff.Metadata, Codec.Picture.Tiff.Types, Codec.Picture.BitWriter, Codec.Picture.InternalHelper, Codec.Picture.VectorByteConversion Install-Includes: src/Codec/Picture/ConvGraph.hs Include-Dirs: src/Codec/Picture JuicyPixels-3.2.8/changelog0000644000000000000000000002105512763046173014050 0ustar0000000000000000Change log ========== v3.2.8 September 2016 --------------------- * Added: possibility to retrieve the parsed palette. * Fix: Fixing problem of progressive Jpeg decoding when block height is different of block width (#) v3.2.7.2 June 2016 ------------------ * Fix: no more libjpeg warning when decoding Juicy.Pixels encoded images. v3.2.7.1 May 2016 ----------------- * Fix: some wrongly infinitely looping JPEG decoding v3.2.7 January 2016 ------------------- * Addition: convertRGB8 and convertRGBA8 helper functions * Addition: new output colorspace for JPEG format: Y, RGB & CMYK * Addition: RGBA8 bitmap reading (thanks to mtolly) * Enhancement: Optimized JPG & Tiff reading (thanks to Calvin Beck) * Enhancement: INLINE SPECIALIZE for pixelMap (Pixel8 -> Pixel8) (thx to Calvin Beck) * Fix: GHC 8.0 compilation (thanks to phadej) v3.2.6.5 December 2015 ---------------------- * Fix: Compilation on GHC 7.6/7.8 v3.2.6.4 December 2015 ---------------------- * Fix: previous broken bugfix. v3.2.6.3 November 2015 ---------------------- * Fix: Fixing unwanted sharing with createMutableImage due to wrongly used INLINE pragma v3.2.6.2 November 2015 ---------------------- * Fix: Using minimal GIF version if outputing a single image. v3.2.6.1 August 2015 -------------------- * Fix: handling of negative height & width in bitmap format. * Fix: regression on Tiff parsing. V3.2.6 August 2015 -------------------- * Added: imageToTga saving helper function. * Fix: don't invert TGA alpha channel. * Fix: various typo in documentation. V3.2.5.3 July 2015 ------------------ * Fix: bumping vector upper bounds. V3.2.5.2 June 2015 ------------------ * Adding: Width & Height metdata to help querying image information without decompressing the whole. * Adding: Source format metadata. v3.2.5.1 May 2015 --------------- * Fixing: utf-8 encoding of Jpg/Types causing problems with Haddock. v3.2.5 May 2015 --------------- * Adding: Metadata extraction for various file format. * Adding: Metadata writing for various file format. * Adding: light EXIF mapping. * Fix: handling of Tiff with predictors (thanks to Patrick Pelletier) v3.2.4 April 2015 ----------------- * Adding: Traversals compatible with the lens library. v3.2.3.2 April 2015 ------------------- * Bumping: zlib max bound v3.2.3.1 March 2015 ------------------- * Bumping: primitive to allow 0.6 * Fix: BMP output generated wrong size (thanks to mtolly). * Fix: 7.10.1 warning free v3.2.3 March 2015 ----------------- * Adding: Support for RGB in jpeg (yeah, that exist...) * Adding: Support of CMYK & YCrCbK color space in jpeg files. * Addinng: a pixelFoldMap functions analog to the `foldMap` function of the Foldable type class. * Fix: better performances for the pixelFold* functions v3.2.2 January 2015 ------------------- * Fix: Squashing GHC 7.10 warnings v3.2.1 December 2014 -------------------- * Fix: Bumping deepseq dependencies preparing for GHC 7.10 release. v3.2 December 2014 ------------------ *BREAKING CHANGES*: the Codec.Picture.Gif functions has changed interfaces. * Adding: TGA reading. * Adding: TGA writing. * Adding: Packeable pixel unpack. * Fix: 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 miscorection 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 v3.1.6 August 2014 ------------------ * Fix bad disposal handling in GIF animations. * Added ColorConvertible instance for PixelRGB8 -> PixelRGBA16 (KaiHa) * Fixing a bad handling of tRNS causing bad transprency decoding in some circonstances. * Adding the concept of Packeable pixel for faster pixel filling using mutable array. v3.1.5.2 May 2014 ----------------- * Bumping the transformers dependency v3.1.5.1 May 2014 ----------------- * Adding some INLINE annotations for some pixel functions 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 :-( v3.1.4 February 2014 -------------------- * Adding a pixelOpacity method to the pixel type class. * Adding handling greyscale BMP files (phischu) * Fixing promotePixel for Pixel8 -> Pixel16 * Some type fixes in the documentation * Updating the pixel conversion graph * Removed URI-encoded images, now using clean cabal embedding v3.1.3.3 February 2014 ---------------------- * Lowering cabal version limit to be compiled with older GHCs v3.1.3.2 January 2014 --------------------- * Hacking around Binary to accept old version of it, down to version 0.5 allowing Juicy.Pixels to be compiled with GHC 6.3 v3.1.3.1 January 2014 --------------------- * Fixing color counting function in color quantisation. * Adding missing documentation for foreign pointer import. v3.1.3 January 2014 ------------------- * Adding palette creation (color Quantization) by Jeffrey Rosenbluth. * Adding support for Gif writing * Adding support for Gif animation writing * Fixing some progressive Jpeg decoding problems (#39) v3.1.2 December 2013 -------------------- * Adding support for progressive jpeg. * Adding support for plane separated MCU jpeg. * Adding support for grayscale 32bit decoding (with reduced precision to 16bits). * Fixing erroneous bitmap decoding in case of excessive padding (#31). v3.1.1.1 October 2013 --------------------- * Fixing some spurious crash while decoding some JPEG image (#30). v3.1.1 October 2013 -------------------- * Adding uncompresed TIFF saving. * Adding error message to avoid loading progressive loading. * Made MMAP optional, controled by a cabal flag. * adding dynamicPixelMap helper function. * Handling png transparency using color key (#26). v3.1 June 2013 -------------- * Adding basic handling of 16bits pixel types. * Addition of Tiff reading: - 2, 4, 8, 16 bit depth reading (planar and contiguous for each). - CMYK, YCbCr, RGB, Paletted, Greyscale. - Uncompressed, PackBits, LZW. * Some new tiny helper functions (nothing too fancy). * Huge performances improvement. v3.0 January 2013 ----------------- * Simplification of the 'Pixel' typeclass, removed many unused part. * Removal of some Storable instances for pixel types. * Amelioration of the documentation. * Support for High Dynamic range images, opening support for different pixel base component. * Support for the Radiance file format (or RGBE, file extension .pic and .hdr). * Dropped the cereal library in favor of the last version of Binary, present in the Haskell platform. Every dependencies are now present in the platform. v2.0.2 October 2012 ------------------- * Decoding of interleaved gif image. * Decoding delta coded gif animation. * Bumping dependencies. v2.0.1 September 2012 --------------------- * Documentation enhancements. * Fixing some huge gif file loading. * Fixing performance problem of Bitmap and Jpeg savings. v2.0 September 2012 ------------------- * New extractComponent version with type safe plane extraction. * Gif file reading. v1.3 June 2012 -------------- * Fix extractComponent function. * Adding saving for YA8 functions. v1.2.1 April 2012 ----------------- * Dependencies version bump. * Dropping array dependency. v1.2 March 2012 --------------- * Adding a generateImage helper function. * Adding NFData instances for image. * Adding JPEG writing. v1.1 February 2012 ------------------ * Switching to vector for arrays, big performance improvement. v1.0 January 2012 ----------------- * Initial release JuicyPixels-3.2.8/docimages/juicy.png0000644000000000000000000000050212303212747015744 0ustar0000000000000000‰PNG  IHDRÀÀ òq4PLTEI¨4“XBÿ«&ÿÿÿGÿQ“tRNS@æØfÞIDATx^ìÖÁ €PÄP[°{Úþ[V?ÿ\ pixelGraphic PixelRGB8 PixelRGB8 PixelRGBA8 PixelRGBA8 PixelRGB8->PixelRGBA8 promotePixel PixelRGBF PixelRGBF PixelRGB8->PixelRGBF promotePixel Pixel8 Pixel8 PixelRGB8->Pixel8 computeLuma PixelCMYK8 PixelCMYK8 PixelRGB8->PixelCMYK8 convertPixel PixelYCbCr8 PixelYCbCr8 PixelRGB8->PixelYCbCr8 convertPixel PixelRGB16 PixelRGB16 PixelRGBA16 PixelRGBA16 PixelRGB16->PixelRGBA16 promotePixel Pixel16 Pixel16 PixelRGB16->Pixel16 computeLuma PixelCMYK16 PixelCMYK16 PixelRGB16->PixelCMYK16 convertPixel PixelRGBA16->PixelRGB16 dropTransparency PixelRGBA8->PixelRGB8 dropTransparency PixelRGBA8->Pixel8 computeLuma PixelF PixelF PixelRGBF->PixelF computeLuma PixelYA16 PixelYA16 PixelYA16->PixelRGBA16 promotePixel PixelYA16->Pixel16 dropTransparency PixelYA8 PixelYA8 PixelYA8->PixelRGB8 promotePixel PixelYA8->PixelRGBA8 promotePixel PixelYA8->Pixel8 dropTransparency PixelYA8->Pixel8 computeLuma PixelF->PixelRGBF promotePixel Pixel16->PixelRGB16 promotePixel Pixel16->PixelRGBA16 promotePixel Pixel16->PixelYA16 promotePixel Pixel8->PixelRGB8 promotePixel Pixel8->PixelRGBA8 promotePixel Pixel8->PixelYA8 promotePixel Pixel8->PixelF promotePixel Pixel8->Pixel16 promotePixel PixelCMYK16->PixelRGB16 convertPixel PixelCMYK8->PixelRGB8 convertPixel PixelYCbCr8->PixelRGB8 convertPixel PixelYCbCr8->Pixel8 computeLuma JuicyPixels-3.2.8/README.md0000644000000000000000000000731512651521220013443 0ustar0000000000000000![Juicy logo](https://raw.github.com/Twinside/Juicy.Pixels/master/docimages/juicy.png) [![Build Status](https://travis-ci.org/Twinside/Juicy.Pixels.png?branch=master)](https://travis-ci.org/Twinside/Juicy.Pixels) [![Hackage](https://img.shields.io/hackage/v/JuicyPixels.svg)](http://hackage.haskell.org/package/JuicyPixels) Juicy.Pixels ============ This library provides saving & loading of different picture formats for the Haskell language. The aim of the library is to be as lightweight as possible, you ask it to load an image, and it'll dump you a big Vector full of juicy pixels. Or squared pixels, or whatever, as long as they're unboxed. Documentation ------------- The library documentation can be accessed on [Hackage](http://hackage.haskell.org/package/JuicyPixels) Wrappers -------- For the user of: * [REPA](http://www.haskell.org/haskellwiki/Numeric_Haskell:_A_Repa_Tutorial), check-out JuicyPixels-repa on [GitHub](https://github.com/TomMD/JuicyPixels-repa) or [Hackage](http://hackage.haskell.org/package/JuicyPixels-repa) * [Gloss](http://hackage.haskell.org/package/gloss), check-out gloss-juicy on [GitHub](https://github.com/alpmestan/gloss-juicy) or [Hackage](http://hackage.haskell.org/package/gloss-juicy) Status ------ - PNG (.png) * Reading - 1,2,4,8 bits loading, Grayscale, 24bits, 24 bits with alpha, interleaved & filtered (fully compliant with the standard, tested against png suite). * Writing - 8bits RGB (non interleaved) - 8bits RGBA (non interleaved) - 8bits greyscale (non interleaved) - 16bits greyscale (non interleaved) - 16bits RGB (non interleaved) - 16bits RGBA (non interleaved) * Metadata (reading/writing) * in a tEXT chunk: 'Title', 'Description', 'Author', 'Copyright', 'Software', 'Comment', 'Disclaimer', 'Source', 'Warning' * any other tEXT chunk. * in a gAMA field : 'Gamma' * DPI information in a pHYs chunk. - Bitmap (.bmp) (mainly used as a debug output format) * Reading - 32bits (RGBA) images - 24bits (RGB) images - 8bits (greyscale & paletted) images * Writing - 32bits (RGBA) per pixel images - 24bits (RGB) per pixel images - 8 bits greyscale (with palette) * Metadata (reading/writing): DPI information - Jpeg (.jpg, .jpeg) * Reading normal and interlaced baseline DCT image - YCbCr (default) CMYK/YCbCrK/RGB colorspaces * Writing non-interlaced JPG - YCbCr (favored), Y, RGB & CMYK colorspaces * Metadata: - Reading and writing DpiX & DpiY from JFIF header. - Reading EXIF metadata. - Gif (.gif) * Reading single image & animated Gif image, handles interlaced images. * Writing single & animated Gif images. * No metadata. - Radiance (.pic, .hdr) * Reading * Writing * No metadata. - Tga * Reading - 8, 16, 24 & 32 bits - paletted and unpaletted - RLE encoded or uncompressed * Writing - uncompressed 8bits (Pixel8) - uncompressed 24bits (PixelRGB8) - uncompressed 32bits (PixelRGBA8) * No metadata - Tiff * Reading - 2, 4, 8, 16 bit depth reading (planar and contiguous for each) - CMYK, YCbCr, RGB, RGBA, Paletted, Greyscale - Uncompressed, PackBits, LZW * Writing - 8 and 16 bits - CMYK, YCbCr, RGB, RGBA, Greyscale - Uncompressed * Metadata: reading DpiX, DpiY and EXIF informations. _I love juicy pixels_ You can make [donations on this page](http://twinside.github.com/Juicy.Pixels/).