diff --git a/Codec/Picture.hs b/Codec/Picture.hs --- a/Codec/Picture.hs +++ b/Codec/Picture.hs @@ -23,6 +23,7 @@ , saveBmpImage , saveJpgImage , savePngImage + , saveTiffImage , saveRadianceImage -- * Specific image format functions @@ -56,7 +57,11 @@ , writeDynamicPng -- ** Tiff handling + , readTiff + , TiffSaveable , decodeTiff + , encodeTiff + , writeTiff -- ** HDR (Radiance/RGBE) handling , readHDR @@ -101,11 +106,16 @@ , encodeHDR , writeHDR ) -import Codec.Picture.Tiff( decodeTiff ) +import Codec.Picture.Tiff( decodeTiff + , TiffSaveable + , encodeTiff + , writeTiff ) import Codec.Picture.Saving import Codec.Picture.Types -- 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 @@ -125,7 +135,12 @@ -> IO (Either String a) withImageDecoder decoder path = Exc.catch doit (\e -> return . Left $ show (e :: Exc.IOException)) - where doit = force . decoder <$> mmapFileByteString path Nothing + 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 -- provide 1.1 force x = x `deepseq` x @@ -156,6 +171,10 @@ 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 [Image PixelRGB8]) @@ -177,11 +196,15 @@ readHDR = withImageDecoder decodeHDR -- | Save an image to a '.jpg' file, will do everything it can to save an image. -saveJpgImage :: Int -> String -> DynamicImage -> IO () +saveJpgImage :: Int -> FilePath -> DynamicImage -> IO () saveJpgImage quality path img = L.writeFile path $ imageToJpg quality 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 :: String -> DynamicImage -> IO () +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. @@ -189,7 +212,7 @@ -- -- > transcodeToPng :: FilePath -> FilePath -> IO () -- > transcodeToPng pathIn pathOut = do --- > eitherImg <- decodeImage pathIn +-- > eitherImg <- readImage pathIn -- > case eitherImg of -- > Left _ -> return () -- > Right img -> savePngImage pathOut img diff --git a/Codec/Picture/Jpg.hs b/Codec/Picture/Jpg.hs --- a/Codec/Picture/Jpg.hs +++ b/Codec/Picture/Jpg.hs @@ -32,7 +32,7 @@ import Data.Binary.Put( Put , putWord8 , putWord16be - , putLazyByteString + , putLazyByteString ) import Data.Maybe( fromJust ) @@ -74,10 +74,12 @@ | JpgQuantizationTable | JpgHuffmanTableMarker | JpgStartOfScan + | JpgEndOfImage | JpgAppSegment Word8 | JpgExtensionSegment Word8 | JpgRestartInterval + | JpgRestartIntervalEnd Word8 deriving (Eq, Show) type HuffmanTreeInfo = HuffmanPackedTree @@ -103,7 +105,7 @@ deriving Show instance SizeCalculable JpgFrameHeader where - calculateSize hdr = 2 + 1 + 2 + 2 + 1 + calculateSize hdr = 2 + 1 + 2 + 2 + 1 + sum [calculateSize c | c <- jpgComponents hdr] data JpgComponent = JpgComponent @@ -156,7 +158,7 @@ + sum [calculateSize c | c <- scans hdr] + 2 + 1 - + data JpgQuantTableSpec = JpgQuantTableSpec { -- | Stored on 4 bits quantPrecision :: !Word8 @@ -315,6 +317,17 @@ putFrame (JpgScans kind hdr) = put kind >> put hdr +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 + parseFrames :: Get [JpgFrame] parseFrames = do kind <- get @@ -327,6 +340,7 @@ parseFrames case kind of + JpgEndOfImage -> return [] JpgAppSegment c -> (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgExtensionSegment c -> @@ -340,32 +354,43 @@ JpgHuffmanTable [(t, packHuffmanTree . buildPackedHuffmanTree $ huffCodes t) | t <- huffTables] : lst) <$> get <*> parseNextFrame JpgStartOfScan -> - (\frm imgData -> [JpgScanBlob frm imgData]) - <$> get <*> getRemainingLazyBytes + (\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 secondStartOfFrameByteOfKind :: JpgFrameKind -> Word8 -secondStartOfFrameByteOfKind JpgBaselineDCTHuffman = 0xC0 -secondStartOfFrameByteOfKind JpgExtendedSequentialDCTHuffman = 0xC1 -secondStartOfFrameByteOfKind JpgProgressiveDCTHuffman = 0xC2 -secondStartOfFrameByteOfKind JpgLosslessHuffman = 0xC3 -secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTHuffman = 0xC5 -secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTHuffman = 0xC6 -secondStartOfFrameByteOfKind JpgDifferentialLosslessHuffman = 0xC7 -secondStartOfFrameByteOfKind JpgExtendedSequentialArithmetic = 0xC9 -secondStartOfFrameByteOfKind JpgProgressiveDCTArithmetic = 0xCA -secondStartOfFrameByteOfKind JpgLosslessArithmetic = 0xCB -secondStartOfFrameByteOfKind JpgHuffmanTableMarker = 0xC4 -secondStartOfFrameByteOfKind JpgDifferentialSequentialDCTArithmetic = 0xCD -secondStartOfFrameByteOfKind JpgDifferentialProgressiveDCTArithmetic = 0xCE -secondStartOfFrameByteOfKind JpgDifferentialLosslessArithmetic = 0xCF -secondStartOfFrameByteOfKind JpgQuantizationTable = 0xDB -secondStartOfFrameByteOfKind JpgStartOfScan = 0xDA -secondStartOfFrameByteOfKind JpgRestartInterval = 0xDD -secondStartOfFrameByteOfKind (JpgAppSegment a) = a -secondStartOfFrameByteOfKind (JpgExtensionSegment a) = a +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 + aux (JpgExtensionSegment a) = a +data JpgImageKind = BaseLineDCT | ProgressiveDCT + instance Binary JpgFrameKind where put v = putWord8 0xFF >> put (secondStartOfFrameByteOfKind v) get = do @@ -387,11 +412,13 @@ 0xCD -> JpgDifferentialSequentialDCTArithmetic 0xCE -> JpgDifferentialProgressiveDCTArithmetic 0xCF -> JpgDifferentialLosslessArithmetic + 0xD9 -> JpgEndOfImage 0xDA -> JpgStartOfScan 0xDB -> JpgQuantizationTable 0xDD -> JpgRestartInterval a | a >= 0xF0 -> JpgExtensionSegment a | a >= 0xE0 -> JpgAppSegment a + | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") put4BitsOfEach :: Word8 -> Word8 -> Put @@ -478,6 +505,7 @@ specBeg <- get specEnd <- get (approxHigh, approxLow) <- get4BitOfEach + return JpgScanHeader { scanLength = thisScanLength, scanComponentCount = compCount, @@ -651,6 +679,12 @@ lift $ (mutableBlock `M.unsafeWrite` (n + rrrr)) decoded parseAcCoefficient (n + rrrr + 1) +{- +decodeEOB :: HuffmanTreeInfo -> BoolReader s Int32 +decodeEOB tree = do + rrrrssss <- huffmanPackedDecode tree + -} + -- | Decompress a macroblock from a bitstream given the current configuration -- from the frame. decompressMacroBlock :: HuffmanTreeInfo -- ^ Tree used for DC coefficient @@ -672,8 +706,10 @@ gatherQuantTables img = concat [t | JpgQuantTable t <- jpgFrame img] gatherHuffmanTables :: JpgImage -> [(JpgHuffmanTableSpec, HuffmanTreeInfo)] -gatherHuffmanTables img = concat [lst | JpgHuffmanTable lst <- jpgFrame img] +gatherHuffmanTables img = + concat [lst | JpgHuffmanTable lst <- jpgFrame img] ++ defaultHuffmanTables + gatherScanInfo :: JpgImage -> (JpgFrameKind, JpgFrameHeader) gatherScanInfo img = fromJust $ unScan <$> find scanDesc (jpgFrame img) where scanDesc (JpgScans _ _) = True @@ -699,7 +735,7 @@ blockVert writeIdx readingIdx j = blockHoriz writeIdx readingIdx zero where blockHoriz _ readIdx i | i >= 8 = blockVert (writeIdx + imgWidth) readIdx $ j + 1 blockHoriz idx readIdx i = do - val <- pixelClamp <$> (block `M.unsafeRead` readIdx) + val <- pixelClamp <$> (block `M.unsafeRead` readIdx) (img `M.unsafeWrite` idx) val blockHoriz (idx + 1) (readIdx + 1) $ i + 1 @@ -709,7 +745,7 @@ -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () -unpack444Ycbcr compIdx x y +unpack444Ycbcr compIdx x y (MutableImage { mutableImageWidth = imgWidth, mutableImageData = img }) block = blockVert baseIdx 0 zero where zero = 0 :: Int @@ -717,14 +753,14 @@ blockVert _ _ j | j >= 8 = 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)) + 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 * 1))) val1 @@ -750,7 +786,7 @@ -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () -unpack422Ycbcr compIdx x y +unpack422Ycbcr compIdx x y (MutableImage { mutableImageWidth = imgWidth, mutableImageHeight = _, mutableImageData = img }) block = blockVert baseIdx 0 zero @@ -760,7 +796,7 @@ blockVert _ _ j | j >= 8 = return () blockVert idx readIdx j = do - v0 <- pixelClamp <$> (block `M.unsafeRead` readIdx) + 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)) @@ -808,7 +844,7 @@ -> MutableImage s PixelYCbCr8 -> MutableMacroBlock s Int16 -> ST s () -unpackMacroBlock compCount compIdx wCoeff hCoeff x y +unpackMacroBlock compCount compIdx wCoeff hCoeff x y (MutableImage { mutableImageWidth = imgWidth, mutableImageHeight = imgHeight, mutableImageData = img }) block = -- trace (printf "w:%d h:%d x:%d y:%d wCoeff:%d hCoeff:%d" imgWidth imgHeight x y wCoeff hCoeff) $ @@ -849,7 +885,7 @@ else return (-1) -} -decodeImage :: JpgImage +decodeImage :: JpgImage -> Int -- ^ Component count -> MutableImage s PixelYCbCr8 -- ^ Result image to write into -> BoolReader s () @@ -859,48 +895,57 @@ let huffmans = gatherHuffmanTables img huffmanForComponent dcOrAc dest = - head [t | (h,t) <- huffmans, huffmanTableClass h == dcOrAc - , huffmanTableDest h == dest] - + case [t | (h,t) <- huffmans + , huffmanTableClass h == dcOrAc + , huffmanTableDest h == dest] of + (v:_) -> v + [] -> error "No Huffman table" + mcuBeforeRestart = case [i | JpgIntervalRestart i <- jpgFrame img] of [] -> maxBound :: Int -- HUUUUUUGE value (enough to parse all MCU) (x:_) -> fromIntegral x - + quants = gatherQuantTables img quantForComponent dest = - head [quantTable q | q <- quants, quantDestination q == dest] - - hdr = head [h | JpgScanBlob h _ <- jpgFrame img] - + case [quantTable q | q <- quants, quantDestination q == dest] of + (v:_) -> v + [] -> error "No quant table" + + hdr = case [h | JpgScanBlob h _ <- jpgFrame img] of + [] -> error "No scan blob" + (v:_) -> v + (_, scanInfo) = gatherScanInfo img imgWidth = fromIntegral $ jpgWidth scanInfo imgHeight = fromIntegral $ jpgHeight scanInfo - + blockSizeOfDim fullDim maxBlockSize = block + (if rest /= 0 then 1 else 0) where (block, rest) = fullDim `divMod` maxBlockSize - + horizontalSamplings = [horiz | (horiz, _, _, _, _, _) <- componentsInfo] - + imgComponentCount = fromIntegral $ jpgImageComponentCount scanInfo :: Int isImageLumanOnly = imgComponentCount == 1 maxHorizFactor | not isImageLumanOnly && not (allElementsEqual horizontalSamplings) = maximum horizontalSamplings | otherwise = 1 - + verticalSamplings = [vert | (_, vert, _, _, _, _) <- componentsInfo] maxVertFactor | not isImageLumanOnly && not (allElementsEqual verticalSamplings) = maximum verticalSamplings | otherwise = 1 - + horizontalBlockCount = blockSizeOfDim imgWidth $ fromIntegral (maxHorizFactor * 8) - + verticalBlockCount = blockSizeOfDim imgHeight $ fromIntegral (maxVertFactor * 8) fetchTablesForComponent component = (horizCount, vertCount, dcTree, acTree, qTable, unpacker) where idx = componentIdentifier component - descr = head [c | c <- scans hdr, componentSelector c == idx] + descr = case [c | c <- scans hdr, componentSelector c == idx] of + (v:_) -> v + [] -> error "No scan" dcTree = huffmanForComponent DcComponent $ dcEntropyCodingTable descr acTree = huffmanForComponent AcComponent $ acEntropyCodingTable descr qTable = quantForComponent $ if idx == 1 then 0 else 1 @@ -916,11 +961,11 @@ unpacker = unpackerDecision xScalingFactor yScalingFactor - unpackerDecision 1 1 | isImageLumanOnly = unpack444Y + unpackerDecision 1 1 | isImageLumanOnly = unpack444Y | otherwise = unpack444Ycbcr . fromIntegral $ idx - 1 unpackerDecision 2 1 = unpack422Ycbcr . fromIntegral $ idx - 1 unpackerDecision _ _ = unpackMacroBlock compCount (fromIntegral $ idx - 1) xScalingFactor yScalingFactor - + componentsInfo = map fetchTablesForComponent $ jpgComponents scanInfo let blockIndices = [(x,y) | y <- [0 .. verticalBlockCount - 1] @@ -971,6 +1016,16 @@ allElementsEqual [] = True allElementsEqual (x:xs) = all (== x) xs +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 + + -- | Try to decompress 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 'convertImage' from the 'ColorSpaceConvertible' @@ -985,15 +1040,18 @@ decodeJpeg :: B.ByteString -> Either String DynamicImage decodeJpeg file = case runGetStrict get file of Left err -> Left err - Right img -> case compCount of - 1 -> Right . ImageY8 $ Image imgWidth imgHeight pixelData - 3 -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData + Right img -> case (compCount, imgKind) of + (_, Nothing) -> Left "Unknown Jpg kind" + (_, Just ProgressiveDCT) -> Left "Unsupported Progressive JPEG image" + (1, _) -> Right . ImageY8 $ Image imgWidth imgHeight pixelData + (3, _) -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData _ -> Left "Wrong component count" where (imgData:_) = [d | JpgScanBlob _kind d <- jpgFrame img] (_, scanInfo) = gatherScanInfo img compCount = length $ jpgComponents scanInfo + imgKind = gatherImageKind $ jpgFrame img imgWidth = fromIntegral $ jpgWidth scanInfo imgHeight = fromIntegral $ jpgHeight scanInfo @@ -1100,7 +1158,7 @@ prepareHuffmanTable :: DctComponent -> Word8 -> HuffmanTable -> (JpgHuffmanTableSpec, HuffmanTreeInfo) -prepareHuffmanTable classVal dest tableDef = +prepareHuffmanTable classVal dest tableDef = (JpgHuffmanTableSpec { huffmanTableClass = classVal , huffmanTableDest = dest , huffSizes = sizes @@ -1108,7 +1166,7 @@ [VU.fromListN (fromIntegral $ sizes ! i) lst | (i, lst) <- zip [0..] tableDef ] }, VS.singleton 0) - where sizes = VU.fromListN 16 $ map (fromIntegral . length) tableDef + 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 @@ -1116,6 +1174,14 @@ encodeJpeg :: Image PixelYCbCr8 -> L.ByteString encodeJpeg = encodeJpegAtQuality 50 +defaultHuffmanTables :: [(JpgHuffmanTableSpec, HuffmanTreeInfo)] +defaultHuffmanTables = + [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable + , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable + , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable + , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable + ] + -- | Function to call to encode an image to jpeg. -- The quality factor should be between 0 and 100 (100 being -- the best quality). @@ -1125,16 +1191,10 @@ encodeJpegAtQuality quality img@(Image { imageWidth = w, imageHeight = h }) = encode finalImage where finalImage = JpgImage [ JpgQuantTable quantTables , JpgScans JpgBaselineDCTHuffman hdr - , JpgHuffmanTable huffTables + , JpgHuffmanTable defaultHuffmanTables , JpgScanBlob scanHeader encodedImage ] - huffTables = [ prepareHuffmanTable DcComponent 0 defaultDcLumaHuffmanTable - , prepareHuffmanTable AcComponent 0 defaultAcLumaHuffmanTable - , prepareHuffmanTable DcComponent 1 defaultDcChromaHuffmanTable - , prepareHuffmanTable AcComponent 1 defaultAcChromaHuffmanTable - ] - outputComponentCount = 3 scanHeader = scanHeader'{ scanLength = fromIntegral $ calculateSize scanHeader' } @@ -1161,7 +1221,7 @@ } hdr = hdr' { jpgFrameHeaderLength = fromIntegral $ calculateSize hdr' } - hdr' = JpgFrameHeader{ jpgFrameHeaderLength = 0 + hdr' = JpgFrameHeader { jpgFrameHeaderLength = 0 , jpgSamplePrecision = 8 , jpgHeight = fromIntegral h , jpgWidth = fromIntegral w @@ -1186,12 +1246,12 @@ } lumaQuant = scaleQuantisationMatrix (fromIntegral quality) - defaultLumaQuantizationTable + defaultLumaQuantizationTable chromaQuant = scaleQuantisationMatrix (fromIntegral quality) defaultChromaQuantizationTable zigzagedLumaQuant = zigZagReorderForwardv lumaQuant - zigzagedChromaQuant = zigZagReorderForwardv chromaQuant + zigzagedChromaQuant = zigZagReorderForwardv chromaQuant quantTables = [ JpgQuantTableSpec { quantPrecision = 0, quantDestination = 0 , quantTable = zigzagedLumaQuant } , JpgQuantTableSpec { quantPrecision = 0, quantDestination = 1 @@ -1209,7 +1269,7 @@ , makeInverseTable defaultDcChromaHuffmanTree , makeInverseTable defaultAcChromaHuffmanTree) componentDef = [lumaSamplingSize, chromaSamplingSize, chromaSamplingSize] - + imageComponentCount = length componentDef dc_table <- M.replicate 3 0 @@ -1227,16 +1287,16 @@ component ((comp, (sizeX, sizeY, table, dc, ac)) : comp_rest) = line 0 where xSamplingFactor = maxSampling - sizeX + 1 ySamplingFactor = maxSampling - sizeY + 1 - extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount + extractor = extractBlock img block xSamplingFactor ySamplingFactor imageComponentCount line subY | subY >= sizeY = component comp_rest line subY = column 0 where blockY = my * sizeY + subY - + column subX | subX >= sizeX = line (subY + 1) column subX = do let blockX = mx * sizeX + subX prev_dc <- dc_table `M.unsafeRead` comp - (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= + (dc_coeff, neo_block) <- (extractor comp blockX blockY >>= encodeMacroBlock table workData zigzaged prev_dc) (dc_table `M.unsafeWrite` comp) $ fromIntegral dc_coeff serializeMacroBlock writeState dc ac neo_block diff --git a/Codec/Picture/Png.hs b/Codec/Picture/Png.hs --- a/Codec/Picture/Png.hs +++ b/Codec/Picture/Png.hs @@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ViewPatterns #-} -- | Module used for loading & writing \'Portable Network Graphics\' (PNG) -- files. The API has two layers, the high level, which load the image without -- looking deeply about it and the low level, allowing access to data chunks contained @@ -402,6 +403,13 @@ pixels = concat [[r, g, b] | ipx <- V.toList img , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] +applyPaletteWithTransparency :: PngPalette -> Word8 -> V.Vector Word8 -> V.Vector Word8 +applyPaletteWithTransparency pal transp img = V.fromListN ((initSize + 1) * 4) pixels + where (_, initSize) = bounds img + pixels = concat [ if ipx == transp then [0, 0, 0, 0] else [r, g, b, 255] + | ipx <- V.toList img + , let PixelRGB8 r g b = pixelAt pal (fromIntegral ipx) 0] + -- | 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 @@ -442,31 +450,41 @@ toImage _const1 const2 (Right a) = Right . const2 $ Image (fromIntegral w) (fromIntegral h) a - palette8 palette (Left img) = + palette8 palette [(Lb.uncons -> Just (c,_))] (Left img) = + Right . ImageRGBA8 + . Image (fromIntegral w) (fromIntegral h) + $ applyPaletteWithTransparency palette c img + + palette8 palette _ (Left img) = Right . ImageRGB8 . Image (fromIntegral w) (fromIntegral h) $ applyPalette palette img - palette8 _ (Right _) = Left "Invalid bit depth for paleted image" - unparse _ PngGreyscale bytes - | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) PngIndexedColor bytes - | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) PngIndexedColor bytes - | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) PngIndexedColor bytes + palette8 _ _ (Right _) = Left "Invalid bit depth for paleted image" + + transparencyColor = + [ chunkData chunk | chunk <- chunks rawImg + , chunkType chunk == tRNSSignature ] + + unparse _ t PngGreyscale bytes + | bitDepth ihdr == 1 = unparse (Just paletteRGBA1) t PngIndexedColor bytes + | bitDepth ihdr == 2 = unparse (Just paletteRGBA2) t PngIndexedColor bytes + | bitDepth ihdr == 4 = unparse (Just paletteRGBA4) t PngIndexedColor bytes | otherwise = toImage ImageY8 ImageY16 $ runST stArray where stArray = deinterlacer ihdr bytes - unparse Nothing PngIndexedColor _ = Left "no valid palette found" - unparse _ PngTrueColour bytes = + unparse Nothing _ PngIndexedColor _ = Left "no valid palette found" + unparse _ _ PngTrueColour bytes = toImage ImageRGB8 ImageRGB16 $ runST stArray where stArray = deinterlacer ihdr bytes - unparse _ PngGreyscaleWithAlpha bytes = + unparse _ _ PngGreyscaleWithAlpha bytes = toImage ImageYA8 ImageYA16 $ runST stArray where stArray = deinterlacer ihdr bytes - unparse _ PngTrueColourWithAlpha bytes = + unparse _ _ PngTrueColourWithAlpha bytes = toImage ImageRGBA8 ImageRGBA16 $ runST stArray where stArray = deinterlacer ihdr bytes - unparse (Just plte) PngIndexedColor bytes = - palette8 plte $ runST stArray + unparse (Just plte) transparency PngIndexedColor bytes = + palette8 plte transparency $ runST stArray where stArray = deinterlacer ihdr bytes if Lb.length compressedImageData <= zlibHeaderSize @@ -478,5 +496,5 @@ Just p -> case parsePalette p of Left _ -> Nothing Right plte -> Just plte - in unparse palette (colourType ihdr) parseableData + in unparse palette transparencyColor (colourType ihdr) parseableData diff --git a/Codec/Picture/Png/Export.hs b/Codec/Picture/Png/Export.hs --- a/Codec/Picture/Png/Export.hs +++ b/Codec/Picture/Png/Export.hs @@ -23,12 +23,12 @@ import Codec.Picture.Types import Codec.Picture.Png.Type -import Codec.Picture.VectorByteConversion +import Codec.Picture.VectorByteConversion( blitVector ) -- | Encode an image into a png if possible. class PngSavable a where -- | Transform an image into a png encoded bytestring, ready - -- to be writte as a file. + -- to be written as a file. encodePng :: Image a -> Lb.ByteString preparePngHeader :: Image a -> PngImageType -> Word8 -> PngIHdr diff --git a/Codec/Picture/Png/Type.hs b/Codec/Picture/Png/Type.hs --- a/Codec/Picture/Png/Type.hs +++ b/Codec/Picture/Png/Type.hs @@ -9,6 +9,7 @@ , pLTESignature , iDATSignature , iENDSignature + , tRNSSignature -- * Low level types , ChunkSignature , PngRawImage( .. ) @@ -35,6 +36,7 @@ import Data.List( foldl' ) import Data.Word( Word32, Word8 ) import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LS import Codec.Picture.Types import Codec.Picture.InternalHelper @@ -264,29 +266,32 @@ -- | Signature signalling that the following data will be a png image -- in the png bit stream pngSignature :: ChunkSignature -pngSignature = signature [137, 80, 78, 71, 13, 10, 26, 10] +pngSignature = L.pack [137, 80, 78, 71, 13, 10, 26, 10] -- | Helper function to help pack signatures. -signature :: [Word8] -> ChunkSignature -signature = L.pack . map (toEnum . fromEnum) +signature :: String -> ChunkSignature +signature = LS.pack -- | Signature for the header chunk of png (must be the first) iHDRSignature :: ChunkSignature -iHDRSignature = signature [73, 72, 68, 82] +iHDRSignature = signature "IHDR" -- | Signature for a palette chunk in the pgn file. Must -- occure before iDAT. pLTESignature :: ChunkSignature -pLTESignature = signature [80, 76, 84, 69] +pLTESignature = signature "PLTE" -- | Signature for a data chuck (with image parts in it) iDATSignature :: ChunkSignature -iDATSignature = signature [73, 68, 65, 84] +iDATSignature = signature "IDAT" -- | Signature for the last chunk of a png image, telling -- the end. iENDSignature :: ChunkSignature -iENDSignature = signature [73, 69, 78, 68] +iENDSignature = signature "IEND" + +tRNSSignature :: ChunkSignature +tRNSSignature = signature "tRNS" instance Binary PngImageType where put PngGreyscale = putWord8 0 diff --git a/Codec/Picture/Saving.hs b/Codec/Picture/Saving.hs --- a/Codec/Picture/Saving.hs +++ b/Codec/Picture/Saving.hs @@ -4,6 +4,7 @@ module Codec.Picture.Saving( imageToJpg , imageToPng , imageToBitmap + , imageToTiff , imageToRadiance ) where @@ -15,6 +16,7 @@ import Codec.Picture.Png import Codec.Picture.HDR import Codec.Picture.Types +import Codec.Picture.Tiff import qualified Data.Vector.Storable as V @@ -124,6 +126,24 @@ 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 diff --git a/Codec/Picture/Tiff.hs b/Codec/Picture/Tiff.hs --- a/Codec/Picture/Tiff.hs +++ b/Codec/Picture/Tiff.hs @@ -2,6 +2,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | Module implementing TIFF decoding. -- -- Supported compression schemes : @@ -22,11 +24,12 @@ -- -- * 16 bits -- -module Codec.Picture.Tiff( decodeTiff ) where +module Codec.Picture.Tiff( decodeTiff, TiffSaveable, encodeTiff, writeTiff ) where import Control.Applicative( (<$>), (<*>), pure ) import Control.Monad( when, replicateM, foldM_ ) import Control.Monad.ST( ST, runST ) +import Control.Monad.Writer.Strict( execWriter, tell, Writer ) import Data.Int( Int8 ) import Data.Word( Word8, Word16 ) import Data.Bits( (.&.), (.|.), unsafeShiftL, unsafeShiftR ) @@ -38,24 +41,28 @@ , skip , getByteString ) -import Data.Binary.Put( Put +import Data.Binary.Put( Put, runPut , putWord16le, putWord16be - , putWord32le, putWord32be ) + , putWord32le, putWord32be + , putByteString + ) +import Data.List( sortBy, mapAccumL ) import qualified Data.Vector as V import qualified Data.Vector.Storable as VS import qualified Data.Vector.Storable.Mutable as M import Data.Word( Word32 ) import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as Lb import qualified Data.ByteString.Unsafe as BU -{-import Debug.Trace-} -{-import Text.Groom-} +import Foreign.Storable( sizeOf ) import Codec.Picture.InternalHelper import Codec.Picture.BitWriter import Codec.Picture.Types import Codec.Picture.Gif.LZW +import Codec.Picture.VectorByteConversion( toByteString ) data Endianness = EndianLittle | EndianBig @@ -72,46 +79,52 @@ 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) -putWord16Endian :: Endianness -> Word16 -> Put -putWord16Endian EndianLittle = putWord16le -putWord16Endian EndianBig = putWord16be +instance BinaryParam Endianness Word16 where + putP EndianLittle = putWord16le + putP EndianBig = putWord16be -getWord16Endian :: Endianness -> Get Word16 -getWord16Endian EndianLittle = getWord16le -getWord16Endian EndianBig = getWord16be + getP EndianLittle = getWord16le + getP EndianBig = getWord16be -putWord32Endian :: Endianness -> Word32 -> Put -putWord32Endian EndianLittle = putWord32le -putWord32Endian EndianBig = putWord32be +instance BinaryParam Endianness Word32 where + putP EndianLittle = putWord32le + putP EndianBig = putWord32be -getWord32Endian :: Endianness -> Get Word32 -getWord32Endian EndianLittle = getWord32le -getWord32Endian EndianBig = getWord32be + getP EndianLittle = getWord32le + getP EndianBig = getWord32be instance Binary TiffHeader where put hdr = do let endian = hdrEndianness hdr put endian - putWord16Endian endian 42 - putWord32Endian endian $ hdrOffset hdr + putP endian (42 :: Word16) + putP endian $ hdrOffset hdr get = do endian <- get - magic <- getWord16Endian endian - when (magic /= 42) + magic <- getP endian + let magicValue = 42 :: Word16 + when (magic /= magicValue) (fail "Invalid TIFF magic number") - TiffHeader endian <$> getWord32Endian endian + TiffHeader endian <$> getP endian data TiffPlanarConfiguration = PlanarConfigContig -- = 1 | PlanarConfigSeparate -- = 2 - deriving (Eq, Show) planarConfgOfConstant :: Word32 -> Get TiffPlanarConfiguration planarConfgOfConstant 0 = pure PlanarConfigContig @@ -119,13 +132,16 @@ 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 - deriving (Eq, Show) data IfdType = TypeByte | TypeAscii @@ -139,62 +155,64 @@ | TypeSignedRational | TypeFloat | TypeDouble - deriving (Eq, Show) -{- -wordOfType :: IfdType -> Word16 -wordOfType TypeByte = 1 -wordOfType TypeAscii = 2 -wordOfType TypeShort = 3 -wordOfType TypeLong = 4 -wordOfType TypeRational = 5 -wordOfType TypeSByte = 6 -wordOfType TypeUndefined = 7 -wordOfType TypeSignedShort = 8 -wordOfType TypeSignedLong = 9 -wordOfType TypeSignedRational = 10 -wordOfType TypeFloat = 11 -wordOfType TypeDouble = 12 - -- -} +instance BinaryParam Endianness IfdType where + getP endianness = getP endianness >>= conv + where + conv :: Word16 -> Get IfdType + conv 1 = return TypeByte + conv 2 = return TypeAscii + conv 3 = return TypeShort + conv 4 = return TypeLong + conv 5 = return TypeRational + conv 6 = return TypeSByte + conv 7 = return TypeUndefined + conv 8 = return TypeSignedShort + conv 9 = return TypeSignedLong + conv 10 = return TypeSignedRational + conv 11 = return TypeFloat + conv 12 = return TypeDouble + conv _ = fail "Invalid TIF directory type" -typeOfWord :: Word16 -> Get IfdType -typeOfWord 1 = return TypeByte -typeOfWord 2 = return TypeAscii -typeOfWord 3 = return TypeShort -typeOfWord 4 = return TypeLong -typeOfWord 5 = return TypeRational -typeOfWord 6 = return TypeSByte -typeOfWord 7 = return TypeUndefined -typeOfWord 8 = return TypeSignedShort -typeOfWord 9 = return TypeSignedLong -typeOfWord 10 = return TypeSignedRational -typeOfWord 11 = return TypeFloat -typeOfWord 12 = return TypeDouble -typeOfWord _ = fail "Invalid TIF directory type" + putP endianness = putP endianness . conv + where + conv :: IfdType -> Word16 + conv TypeByte = 1 + conv TypeAscii = 2 + conv TypeShort = 3 + conv TypeLong = 4 + conv TypeRational = 5 + conv TypeSByte = 6 + conv TypeUndefined = 7 + conv TypeSignedShort = 8 + conv TypeSignedLong = 9 + conv TypeSignedRational = 10 + conv TypeFloat = 11 + conv TypeDouble = 12 data TiffTag = TagPhotometricInterpretation - | TagCompression - | TagImageWidth - | TagImageLength - | TagXResolution - | TagYResolution - | TagResolutionUnit - | TagRowPerStrip - | TagStripByteCounts - | TagStripOffsets - | TagBitsPerSample - | TagColorMap + | 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 + | TagSamplesPerPixel -- ^ Short | TagArtist | TagDocumentName | TagSoftware - | TagPlanarConfiguration + | TagPlanarConfiguration -- ^ Short | TagOrientation - | TagSampleFormat + | TagSampleFormat -- ^ Short | TagInkSet | TagSubfileType | TagFillOrder @@ -267,6 +285,57 @@ aux 532 = TagReferenceBlackWhite aux v = TagUnknown v +word16OfTag :: TiffTag -> Word16 +word16OfTag = aux + where aux TagSubfileType = 255 + aux TagImageWidth = 256 + aux TagImageLength = 257 + aux TagBitsPerSample = 258 + aux TagCompression = 259 + aux TagPhotometricInterpretation = 262 + aux TagFillOrder = 266 + aux TagDocumentName = 269 + aux TagImageDescription = 270 + aux TagStripOffsets = 273 + aux TagOrientation = 274 + aux TagSamplesPerPixel = 277 + aux TagRowPerStrip = 278 + aux TagStripByteCounts = 279 + aux TagXResolution = 282 + aux TagYResolution = 283 + aux TagPlanarConfiguration = 284 + aux TagXPosition = 286 + aux TagYPosition = 287 + aux TagResolutionUnit = 296 + aux TagSoftware = 305 + aux TagArtist = 315 + aux TagColorMap = 320 + aux TagTileWidth = 322 + aux TagTileLength = 323 + aux TagTileOffset = 324 + aux TagTileByteCount = 325 + aux TagInkSet = 332 + aux TagExtraSample = 338 + aux TagSampleFormat = 339 + aux TagYCbCrCoeff = 529 + aux TagJpegProc = 512 + aux TagJPEGInterchangeFormat = 513 + aux TagJPEGInterchangeFormatLength = 514 + aux TagJPEGRestartInterval = 515 + aux TagJPEGLosslessPredictors = 517 + aux TagJPEGPointTransforms = 518 + aux TagJPEGQTables = 519 + aux TagJPEGDCTables = 520 + aux TagJPEGACTables = 521 + aux TagYCbCrSubsampling = 530 + aux TagYCbCrPositioning = 531 + aux TagReferenceBlackWhite = 532 + aux (TagUnknown v) = v + +instance BinaryParam Endianness TiffTag where + getP endianness = tagOfWord16 <$> getP endianness + putP endianness = putP endianness . word16OfTag + data ExtendedDirectoryData = ExtendedDataNone | ExtendedDataAscii !B.ByteString @@ -274,20 +343,55 @@ | ExtendedDataLong !(V.Vector Word32) deriving (Eq, Show) +instance BinaryParam (Endianness, ImageFileDirectory) ExtendedDirectoryData where + putP (endianness, _) = dump + where + dump ExtendedDataNone = pure () + dump (ExtendedDataAscii bstr) = putByteString bstr + dump (ExtendedDataShort shorts) = V.mapM_ (putP endianness) shorts + dump (ExtendedDataLong longs) = V.mapM_ (putP endianness) longs + + getP (endianness, ifd) = fetcher ifd + where + align ImageFileDirectory { ifdOffset = offset } = do + readed <- bytesRead + skip . fromIntegral $ fromIntegral offset - readed + + getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness + + getVec count = V.replicateM (fromIntegral count) + + fetcher ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = + align ifd >> (ExtendedDataAscii <$> getByteString (fromIntegral count)) + fetcher ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = + pure . ExtendedDataShort $ 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 = TypeShort, ifdCount = count } | count > 2 = + align ifd >> (ExtendedDataShort <$> getVec count getE) + fetcher ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = + align ifd >> (ExtendedDataLong <$> getVec count getE) + fetcher _ = pure ExtendedDataNone + data TiffSampleFormat = TiffSampleUint | TiffSampleInt | TiffSampleDouble | TiffSampleUnknown - deriving (Eq, Show) + deriving Eq unpackSampleFormat :: Word32 -> Get TiffSampleFormat unpackSampleFormat = aux - where aux 1 = pure TiffSampleUint - aux 2 = pure TiffSampleInt - aux 3 = pure TiffSampleDouble - aux 4 = pure TiffSampleUnknown - aux v = fail $ "Undefined data format (" ++ show v ++ ")" + where + aux 1 = pure TiffSampleUint + aux 2 = pure TiffSampleInt + aux 3 = pure TiffSampleDouble + aux 4 = pure TiffSampleUnknown + aux v = fail $ "Undefined data format (" ++ show v ++ ")" data ImageFileDirectory = ImageFileDirectory { ifdIdentifier :: !TiffTag @@ -296,7 +400,6 @@ , ifdOffset :: !Word32 , ifdExtended :: !ExtendedDirectoryData } - deriving (Eq, Show) unLong :: String -> ExtendedDirectoryData -> Get (V.Vector Word32) unLong _ (ExtendedDataShort v) = pure $ V.map fromIntegral v @@ -309,46 +412,38 @@ aux _ = ifd cleanImageFileDirectory ifd = ifd -getImageFileDirectory :: Endianness -> Get ImageFileDirectory -getImageFileDirectory endianness = - ImageFileDirectory <$> (tagOfWord16 <$> getWord16) - <*> (getWord16 >>= typeOfWord) - <*> getWord32 - <*> getWord32 - <*> pure ExtendedDataNone - where getWord16 = getWord16Endian endianness - getWord32 = getWord32Endian endianness - -getImageFileDirectories :: Endianness -> Get [ImageFileDirectory] -getImageFileDirectories endianness = do - count <- getWord16Endian endianness - replicateM (fromIntegral count) $ getImageFileDirectory endianness - -fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory] -fetchExtended endian = mapM fetcher - where align ImageFileDirectory { ifdOffset = offset } = do - readed <- bytesRead - skip . fromIntegral $ fromIntegral offset - readed - - getWord16 = getWord16Endian endian - getWord32 = getWord32Endian endian - - update ifd v = ifd { ifdExtended = v } - getVec count = V.replicateM (fromIntegral count) +instance BinaryParam Endianness ImageFileDirectory where + getP endianness = + ImageFileDirectory <$> getE <*> getE <*> getE <*> getE + <*> pure ExtendedDataNone + where getE :: (BinaryParam Endianness a) => Get a + getE = getP endianness - fetcher ifd@ImageFileDirectory { ifdType = TypeAscii, ifdCount = count } | count > 1 = - align ifd >> (update ifd . ExtendedDataAscii <$> getByteString (fromIntegral count)) - fetcher ifd@ImageFileDirectory { ifdType = TypeShort, ifdCount = 2, ifdOffset = ofs } = - pure . update ifd . ExtendedDataShort $ V.fromListN 2 [high, low] - where high = fromIntegral $ ofs `unsafeShiftL` 16 - low = fromIntegral $ ofs .&. 0xFFFF + 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 - fetcher ifd@ImageFileDirectory { ifdType = TypeShort, ifdCount = count } | count > 2 = - align ifd >> (update ifd . ExtendedDataShort <$> getVec count getWord16) - fetcher ifd@ImageFileDirectory { ifdType = TypeLong, ifdCount = count } | count > 1 = - align ifd >> (update ifd . ExtendedDataLong <$> getVec count getWord32) +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) - fetcher ifd = pure ifd +fetchExtended :: Endianness -> [ImageFileDirectory] -> Get [ImageFileDirectory] +fetchExtended endian = mapM $ \ifd -> do + v <- getP (endian, ifd) + pure $ ifd { ifdExtended = v } findIFD :: String -> TiffTag -> [ImageFileDirectory] -> Get ImageFileDirectory @@ -382,20 +477,26 @@ val <- findIFD msg tag lst case val of ImageFileDirectory - { ifdCount = 1, ifdOffset = ofs } -> + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeShort } -> pure . ExtendedDataShort . V.singleton $ fromIntegral ofs + ImageFileDirectory + { ifdCount = 1, ifdOffset = ofs, ifdType = TypeLong } -> + pure . ExtendedDataLong . V.singleton $ fromIntegral ofs ImageFileDirectory { ifdExtended = v } -> pure v -findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] -> Get [Word32] +findIFDExtDefaultData :: [Word32] -> TiffTag -> [ImageFileDirectory] + -> Get [Word32] findIFDExtDefaultData d tag lst = case [v | v <- lst, ifdIdentifier v == tag] of [] -> pure d - (x:_) -> V.toList <$> unLong "Can't unlong" (ifdExtended x) + (x:_) -> V.toList <$> + unLong ("Can't unlong " ++ (show tag)) (ifdExtended x) -- It's temporary, remove once tiff decoding is better -- handled. -{- instance Show (Image PixelRGB16) where +{- +instance Show (Image PixelRGB16) where show _ = "Image PixelRGB16" -} @@ -425,8 +526,19 @@ | TiffCMYK -- ^ 5 | TiffYCbCr -- ^ 6 | TiffCIELab -- ^ 8 - deriving (Eq, Show) +packPhotometricInterpretation :: TiffColorspace -> Word16 +packPhotometricInterpretation = aux + where + aux TiffMonochromeWhite0 = 0 + aux TiffMonochrome = 1 + aux TiffRGB = 2 + aux TiffPaleted = 3 + aux TiffTransparencyMask = 4 + aux TiffCMYK = 5 + aux TiffYCbCr = 6 + aux TiffCIELab = 8 + unpackPhotometricInterpretation :: Word32 -> Get TiffColorspace unpackPhotometricInterpretation = aux where aux 0 = pure TiffMonochromeWhite0 @@ -437,17 +549,28 @@ aux 5 = pure TiffCMYK aux 6 = pure TiffYCbCr aux 8 = pure TiffCIELab - aux _ = fail "Unrecognized color space" + aux v = fail $ "Unrecognized color space " ++ show v unPackCompression :: Word32 -> Get TiffCompression -unPackCompression 0 = pure CompressionNone -unPackCompression 1 = pure CompressionNone -unPackCompression 2 = pure CompressionModifiedRLE -unPackCompression 5 = pure CompressionLZW -unPackCompression 6 = pure CompressionJPEG -unPackCompression 32773 = pure CompressionPackBit -unPackCompression v = fail $ "Unknown compression scheme " ++ show v +unPackCompression = aux + where + aux 0 = pure CompressionNone + aux 1 = pure CompressionNone + aux 2 = pure CompressionModifiedRLE + aux 5 = pure CompressionLZW + aux 6 = pure CompressionJPEG + aux 32773 = pure CompressionPackBit + aux v = fail $ "Unknown compression scheme " ++ show v +packCompression :: TiffCompression -> Word16 +packCompression = aux + where + aux CompressionNone = 1 + aux CompressionModifiedRLE = 2 + aux CompressionLZW = 5 + aux CompressionJPEG = 6 + aux CompressionPackBit = 32773 + copyByteString :: B.ByteString -> M.STVector s Word8 -> Int -> Int -> (Word32, Word32) -> ST s Int copyByteString str vec stride startWrite (from, count) = inner startWrite fromi @@ -768,22 +891,129 @@ unsafeFreezeImage mutableImage -getTiffInfo :: Get TiffInfo -getTiffInfo = do +ifdSingleLong :: TiffTag -> Word32 -> Writer [ImageFileDirectory] () +ifdSingleLong tag = ifdMultiLong tag . V.singleton + +ifdSingleShort :: Endianness -> TiffTag -> Word16 + -> Writer [ImageFileDirectory] () +ifdSingleShort endian tag = ifdMultiShort endian tag . V.singleton . fromIntegral + +ifdMultiLong :: TiffTag -> 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, ExtendedDataLong v) + | otherwise = (V.head v, ExtendedDataNone) + +ifdMultiShort :: Endianness -> TiffTag -> 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, ExtendedDataShort $ 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, ExtendedDataNone) + EndianBig -> (v1 `unsafeShiftL` 16 .|. v2, ExtendedDataNone) + + | otherwise = case endian of + EndianLittle -> (V.head v, ExtendedDataNone) + EndianBig -> (V.head v `unsafeShiftL` 16, ExtendedDataNone) + +-- | 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 = ExtendedDataAscii b }) = + (ix + fromIntegral (B.length b), ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataLong v }) + | V.length v > 1 = ( ix + fromIntegral (V.length v * 4) + , ifd { ifdOffset = ix } ) + updater ix ifd@(ImageFileDirectory { ifdExtended = ExtendedDataShort v }) + | V.length v > 2 = ( ix + fromIntegral (V.length v * 2) + , ifd { ifdOffset = ix }) + updater ix ifd = (ix, ifd) + +instance BinaryParam B.ByteString TiffInfo where + putP rawData nfo = do + put $ tiffHeader nfo + + let ifdStartOffset = hdrOffset $ tiffHeader nfo + endianness = hdrEndianness $ tiffHeader nfo + + ifdShort = ifdSingleShort endianness + ifdShorts = ifdMultiShort endianness + list = setupIfdOffsets ifdStartOffset . orderIfdByTag . 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 + + let subSampling = tiffYCbCrSubsampling nfo + when (not $ V.null subSampling) $ + ifdShorts TagYCbCrSubsampling subSampling + + putByteString rawData + putP endianness list + mapM_ (\ifd -> putP (endianness, ifd) $ ifdExtended ifd) list + + getP _ = do hdr <- get readed <- bytesRead skip . fromIntegral $ fromIntegral (hdrOffset hdr) - readed let endian = hdrEndianness hdr - ifd <- fmap cleanImageFileDirectory <$> getImageFileDirectories endian - cleaned <- {- (\a -> trace (groom a) a) <$> -} fetchExtended endian ifd + ifd <- fmap cleanImageFileDirectory <$> getP endian + cleaned <- fetchExtended endian ifd 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 - (\a -> {- trace (groom a) -}a) <$> (TiffInfo hdr + TiffInfo hdr <$> dataFind "Can't find width" TagImageWidth <*> dataFind "Can't find height" TagImageLength <*> (dataFind "Can't find color space" TagPhotometricInterpretation @@ -804,7 +1034,6 @@ >>= unLong "Can't find strip offsets") <*> findPalette cleaned <*> (V.fromList <$> extDefault [2, 2] TagYCbCrSubsampling) - ) unpack :: B.ByteString -> TiffInfo -> Either String DynamicImage unpack file nfo@TiffInfo { tiffColorspace = TiffPaleted @@ -939,5 +1168,84 @@ -- * PixelCMYK16 -- decodeTiff :: B.ByteString -> Either String DynamicImage -decodeTiff file = runGetStrict getTiffInfo file >>= unpack file +decodeTiff file = runGetStrict (getP file) file >>= unpack file + +-- | Class defining which pixel types can be serialized in a +-- Tiff file. +class (Pixel px) => TiffSaveable px where + colorSpaceOfPixel :: px -> TiffColorspace + + subSamplingInfo :: px -> V.Vector Word32 + subSamplingInfo _ = V.empty + +instance TiffSaveable Pixel8 where + colorSpaceOfPixel _ = TiffMonochrome + +instance TiffSaveable Pixel16 where + colorSpaceOfPixel _ = TiffMonochrome + +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 + +instance TiffSaveable PixelRGBA16 where + colorSpaceOfPixel _ = TiffRGB + +instance TiffSaveable PixelYCbCr8 where + colorSpaceOfPixel _ = TiffYCbCr + subSamplingInfo _ = V.fromListN 2 [1, 1] + +-- | Transform an image into a Tiff encoded bytestring, reade 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) + } + +-- | 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 diff --git a/Codec/Picture/Types.hs b/Codec/Picture/Types.hs --- a/Codec/Picture/Types.hs +++ b/Codec/Picture/Types.hs @@ -17,7 +17,7 @@ -- ** Image functions , freezeImage - , unsafeFreezeImage + , unsafeFreezeImage -- ** Pixel types , Pixel8 @@ -43,9 +43,10 @@ , TransparentPixel( .. ) -- * Helper functions - , dynamicMap , pixelMap , pixelFold + , dynamicMap + , dynamicPixelMap , dropAlphaLayer , withImage , generateImage @@ -133,15 +134,15 @@ -- | Define the plane for the Cb component data PlaneCb = PlaneCb --- | Define plane for the cyan component of the +-- | Define plane for the cyan component of the -- CMYK color space. data PlaneCyan = PlaneCyan --- | Define plane for the magenta component of the +-- | Define plane for the magenta component of the -- CMYK color space. data PlaneMagenta = PlaneMagenta --- | Define plane for the yellow component of the +-- | Define plane for the yellow component of the -- CMYK color space. data PlaneYellow = PlaneYellow @@ -227,10 +228,10 @@ -- 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 + mutableImageWidth :: {-# UNPACK #-} !Int -- | Height of the image in pixels. - , mutableImageHeight :: {-# UNPACK #-} !Int + , mutableImageHeight :: {-# UNPACK #-} !Int -- | The real image, to extract pixels at some position -- you should use the helpers functions. @@ -261,7 +262,7 @@ ImageY8 (Image Pixel8) -- | A greyscale image with 16bit components | ImageY16 (Image Pixel16) - -- | A greyscale HDR image + -- | A greyscale HDR image | ImageYF (Image PixelF) -- | An image in greyscale with an alpha channel. | ImageYA8 (Image PixelYA8) @@ -307,6 +308,38 @@ 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 wan't to extract a square crop of any image, +-- without caring about colorspace, you can use the following snippet. +-- +-- > dynSquare :: DynamicImage -> DynamicImage +-- > dynSquare = dynMap 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 @@ -491,6 +524,15 @@ -- 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 + -- | Return the number of component of the pixel componentCount :: a -> Int @@ -651,14 +693,14 @@ -- | Fold over the pixel of an image with a raster scan order : -- from top to bottom, left to right {-# INLINE pixelFold #-} -pixelFold :: (Pixel pixel) +pixelFold :: (Pixel pixel) => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = - lineFold + lineFold where pixelFolder y acc x = f acc x y $ pixelAt img x y columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] lineFold = foldl' columnFold initialAccumulator [0 .. h - 1] - + -- | `map` equivalent for an image, working at the pixel level. -- Little example : a brightness function for an rgb image -- @@ -711,7 +753,7 @@ -- implementation. -- -- > jpegToGrayScale :: FilePath -> FilePath -> IO () - -- > jpegToGrayScale source dest + -- > jpegToGrayScale source dest extractLumaPlane :: Image a -> Image (PixelBaseComponent a) extractLumaPlane = pixelMap computeLuma @@ -768,6 +810,9 @@ instance Pixel Pixel8 where type PixelBaseComponent Pixel8 = Word8 + {-# INLINE mixWith #-} + mixWith f = f 0 + {-# INLINE colorMap #-} colorMap f = f @@ -810,6 +855,9 @@ instance Pixel Pixel16 where type PixelBaseComponent Pixel16 = Word16 + {-# INLINE mixWith #-} + mixWith f = f 0 + {-# INLINE colorMap #-} colorMap f = f @@ -844,6 +892,9 @@ instance Pixel PixelF where type PixelBaseComponent PixelF = Float + {-# INLINE mixWith #-} + mixWith f = f 0 + {-# INLINE colorMap #-} colorMap f = f componentCount _ = 1 @@ -869,6 +920,11 @@ instance Pixel PixelYA8 where type PixelBaseComponent PixelYA8 = Word8 + {-# 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) componentCount _ = 2 @@ -887,7 +943,7 @@ (arr .<-. (baseIdx + 0)) yv (arr .<-. (baseIdx + 1)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) unsafeReadPixel vec idx = PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) @@ -923,6 +979,10 @@ instance Pixel PixelYA16 where type PixelBaseComponent PixelYA16 = Word16 + {-# INLINE mixWith #-} + mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) = + PixelYA16 (f 0 ya yb) (f 1 aa ab) + {-# INLINE colorMap #-} colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a) componentCount _ = 2 @@ -941,7 +1001,7 @@ (arr .<-. (baseIdx + 0)) yv (arr .<-. (baseIdx + 1)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) unsafeReadPixel vec idx = PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) @@ -967,6 +1027,10 @@ instance Pixel PixelRGBF where type PixelBaseComponent PixelRGBF = PixelF + {-# 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) @@ -990,7 +1054,7 @@ (arr .<-. (baseIdx + 1)) gv (arr .<-. (baseIdx + 2)) bv - unsafePixelAt v idx = + unsafePixelAt v idx = PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) unsafeReadPixel vec idx = PixelRGBF `liftM` M.unsafeRead vec idx @@ -1015,6 +1079,10 @@ instance Pixel PixelRGB16 where type PixelBaseComponent PixelRGB16 = Pixel16 + {-# 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) @@ -1038,7 +1106,7 @@ (arr .<-. (baseIdx + 1)) gv (arr .<-. (baseIdx + 2)) bv - unsafePixelAt v idx = + unsafePixelAt v idx = PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) unsafeReadPixel vec idx = PixelRGB16 `liftM` M.unsafeRead vec idx @@ -1076,6 +1144,10 @@ instance Pixel PixelRGB8 where type PixelBaseComponent PixelRGB8 = Word8 + {-# 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) @@ -1099,7 +1171,7 @@ (arr .<-. (baseIdx + 1)) gv (arr .<-. (baseIdx + 2)) bv - unsafePixelAt v idx = + unsafePixelAt v idx = PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) unsafeReadPixel vec idx = PixelRGB8 `liftM` M.unsafeRead vec idx @@ -1139,6 +1211,10 @@ instance Pixel PixelRGBA8 where type PixelBaseComponent PixelRGBA8 = Word8 + {-# 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 colorMap #-} colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) @@ -1165,7 +1241,7 @@ (arr .<-. (baseIdx + 2)) bv (arr .<-. (baseIdx + 3)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelRGBA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) @@ -1198,6 +1274,10 @@ instance Pixel PixelRGBA16 where type PixelBaseComponent PixelRGBA16 = Pixel16 + {-# 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 colorMap #-} colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a) @@ -1223,7 +1303,7 @@ (arr .<-. (baseIdx + 2)) bv (arr .<-. (baseIdx + 3)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelRGBA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) @@ -1261,6 +1341,10 @@ instance Pixel PixelYCbCr8 where type PixelBaseComponent PixelYCbCr8 = Word8 + {-# 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) componentCount _ = 3 @@ -1282,7 +1366,7 @@ (arr .<-. (baseIdx + 1)) cbv (arr .<-. (baseIdx + 2)) crv - unsafePixelAt v idx = + unsafePixelAt v idx = PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) unsafeReadPixel vec idx = PixelYCbCr8 `liftM` M.unsafeRead vec idx @@ -1415,6 +1499,10 @@ instance Pixel PixelCMYK8 where type PixelBaseComponent PixelCMYK8 = Word8 + {-# 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) @@ -1441,7 +1529,7 @@ (arr .<-. (baseIdx + 2)) bv (arr .<-. (baseIdx + 3)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelCMYK8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) @@ -1459,7 +1547,7 @@ instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where convertPixel (PixelCMYK8 c m y k) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) - where + where clampWord8 = fromIntegral . (`unsafeShiftR` 8) ik :: Int ik = 255 - fromIntegral k @@ -1515,6 +1603,10 @@ instance Pixel PixelCMYK16 where type PixelBaseComponent PixelCMYK16 = Word16 + {-# 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) @@ -1541,7 +1633,7 @@ (arr .<-. (baseIdx + 2)) bv (arr .<-. (baseIdx + 3)) av - unsafePixelAt v idx = + unsafePixelAt v idx = PixelCMYK16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) @@ -1559,7 +1651,7 @@ instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where convertPixel (PixelCMYK16 c m y k) = PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b) - where + where clampWord16 = fromIntegral . (`unsafeShiftR` 16) ik :: Int ik = 65535 - fromIntegral k diff --git a/Codec/Picture/VectorByteConversion.hs b/Codec/Picture/VectorByteConversion.hs --- a/Codec/Picture/VectorByteConversion.hs +++ b/Codec/Picture/VectorByteConversion.hs @@ -1,7 +1,10 @@ -module Codec.Picture.VectorByteConversion( blitVector ) where +{-# LANGUAGE ScopedTypeVariables #-} +module Codec.Picture.VectorByteConversion( blitVector, toByteString ) where import Data.Word( Word8 ) import Data.Vector.Storable( Vector, unsafeToForeignPtr ) +import Foreign.ForeignPtr.Safe( castForeignPtr ) +import Foreign.Storable( Storable, sizeOf ) import qualified Data.ByteString as B import qualified Data.ByteString.Internal as S @@ -9,4 +12,9 @@ blitVector :: Vector Word8 -> Int -> Int -> B.ByteString blitVector vec atIndex blitSize = S.PS ptr (offset + atIndex) blitSize 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) diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.1 +Version: 3.1.1 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tiff and radiance) Description: <> @@ -24,8 +24,12 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.1 + Tag: v3.1.1 +Flag Mmap + Description: Enable the file loading via mmap (memory map) + Default: False + Library Default-Language: Haskell2010 Exposed-modules: Codec.Picture, @@ -47,8 +51,11 @@ transformers >= 0.2.2 && < 0.4, vector >= 0.9 && < 0.11, primitive >= 0.5 && < 0.6, - deepseq >= 1.1 && < 1.4, - mmap + deepseq >= 1.1 && < 1.4 + + if flag(Mmap) + Build-depends: mmap + CC-Options: "-DWITH_MMAP_BYTESTRING" -- Modules not exported by this package. Other-modules: Codec.Picture.Jpg.DefaultTable,