diff --git a/JuicyPixels.cabal b/JuicyPixels.cabal --- a/JuicyPixels.cabal +++ b/JuicyPixels.cabal @@ -1,5 +1,5 @@ Name: JuicyPixels -Version: 3.2.2 +Version: 3.2.3 Synopsis: Picture loading/serialization (in png, jpeg, bitmap, gif, tga, tiff and radiance) Description: <> @@ -18,8 +18,8 @@ -- Constraint on the version of Cabal needed to build this package. Cabal-version: >= 1.10 -extra-source-files: changelog, docimages/*.png, docimages/*.svg -extra-doc-files: docimages/*.png, docimages/*.svg +extra-source-files: changelog, docimages/*.png +extra-doc-files: docimages/*.png Source-Repository head Type: git @@ -28,7 +28,7 @@ Source-Repository this Type: git Location: git://github.com/Twinside/Juicy.Pixels.git - Tag: v3.2.2 + Tag: v3.2.3 Flag Mmap Description: Enable the file loading via mmap (memory map) diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,20 +1,27 @@ -*-change-log-*- +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 - * Squashing GHC 7.10 warnings + * Fix: Squashing GHC 7.10 warnings v3.2.1 December 2014 - * Bumping deepseq dependencies preparing for GHC 7.10 + * 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. - * Packeable pixel unpack. - * Returning gif with transparency (breaking Codec.Picture.Gif interface) + * 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 diff --git a/docimages/pixelgraph.svg b/docimages/pixelgraph.svg deleted file mode 100644 --- a/docimages/pixelgraph.svg +++ /dev/null @@ -1,264 +0,0 @@ - - - - - - -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 - - - diff --git a/src/Codec/Picture/BitWriter.hs b/src/Codec/Picture/BitWriter.hs --- a/src/Codec/Picture/BitWriter.hs +++ b/src/Codec/Picture/BitWriter.hs @@ -26,7 +26,7 @@ ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), (<*>) ) +import Control.Applicative( (<*>) ) #endif import Data.STRef diff --git a/src/Codec/Picture/Jpg.hs b/src/Codec/Picture/Jpg.hs --- a/src/Codec/Picture/Jpg.hs +++ b/src/Codec/Picture/Jpg.hs @@ -16,7 +16,7 @@ import Control.Applicative( pure ) #endif -import Control.Applicative( (<$>) ) +import Control.Applicative( (<|>), (<$>) ) import Control.Arrow( (>>>) ) import Control.Monad( when, forM_ ) @@ -234,7 +234,8 @@ , quantizationMatrices :: !(V.Vector (MacroBlock Int16)) , currentRestartInterv :: !Int , currentFrame :: Maybe JpgFrameHeader - , minimumComponentIndex :: !Int + , app14Marker :: !(Maybe JpgAdobeApp14) + , componentIndexMapping :: ![(Word8, Int)] , isProgressive :: !Bool , maximumHorizontalResolution :: !Int , maximumVerticalResolution :: !Int @@ -258,7 +259,8 @@ , quantizationMatrices = V.replicate 4 (VS.replicate (8 * 8) 1) , currentRestartInterv = -1 , currentFrame = Nothing - , minimumComponentIndex = 1 + , componentIndexMapping = [] + , app14Marker = Nothing , isProgressive = False , maximumHorizontalResolution = 0 , maximumVerticalResolution = 0 @@ -268,6 +270,8 @@ -- | 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 (JpgAppFrame _ _) = pure () jpgMachineStep (JpgExtension _ _) = pure () jpgMachineStep (JpgScanBlob hdr raw_data) = do @@ -282,13 +286,15 @@ scanSpecifier scanCount scanSpec = do - minimumIndex <- gets minimumComponentIndex + 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 - comp = fromIntegral (componentSelector scanSpec) - minimumIndex dcTree <- gets $ (V.! dcIndex) . dcDecoderTables acTree <- gets $ (V.! acIndex) . acDecoderTables @@ -335,8 +341,8 @@ jpgMachineStep (JpgScans kind hdr) = modify $ \s -> s { currentFrame = Just hdr - , minimumComponentIndex = - fromIntegral $ minimum [componentIdentifier comp | comp <- jpgComponents hdr] + , componentIndexMapping = + [(componentIdentifier comp, ix) | (ix, comp) <- zip [0..] $ jpgComponents hdr] , isProgressive = case kind of JpgProgressiveDCTHuffman -> True _ -> False @@ -374,7 +380,7 @@ unpackerDecision :: Int -> (Int, Int) -> Unpacker s unpackerDecision 1 (1, 1) = unpack444Y -unpackerDecision _ (1, 1) = unpack444Ycbcr +unpackerDecision 3 (1, 1) = unpack444Ycbcr unpackerDecision _ (2, 1) = unpack421Ycbcr unpackerDecision compCount (xScalingFactor, yScalingFactor) = unpackMacroBlock compCount xScalingFactor yScalingFactor @@ -383,7 +389,7 @@ -> V.Vector (MacroBlock Int16) -> [([(JpgUnpackerParameter, Unpacker s)], L.ByteString)] -> MutableImage s PixelYCbCr8 -- ^ Result image to write into - -> ST s () + -> ST s (MutableImage s PixelYCbCr8) decodeImage frame quants lst outImage = do let compCount = length $ jpgComponents frame zigZagArray <- createEmptyMutableMacroBlock @@ -434,6 +440,8 @@ else lift $ unpack compIdx (x * maxiW + xd) (y * maxiH + yd) outImage block + return outImage + where imgComponentCount = length $ jpgComponents frame imgWidth = fromIntegral $ jpgWidth frame @@ -454,6 +462,58 @@ 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 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' @@ -463,49 +523,61 @@ -- -- * PixelY8 -- +-- * PixelYA8 +-- +-- * PixelRGB8 +-- -- * PixelYCbCr8 -- decodeJpeg :: B.ByteString -> Either String DynamicImage decodeJpeg file = case runGetStrict get file of Left err -> Left err - Right img -> case (compCount, imgKind) of - (_, Nothing) -> Left "Unknown Jpg kind" - (3, Just ProgressiveDCT) -> Right . ImageYCbCr8 $ decodeProgressive - (1, Just BaseLineDCT) -> Right . ImageY8 $ Image imgWidth imgHeight pixelData - (3, Just BaseLineDCT) -> Right . ImageYCbCr8 $ Image imgWidth imgHeight pixelData - _ -> Left "Wrong component count" + Right img -> case imgKind of + Just BaseLineDCT -> + let (st, arr) = decodeBaseline in + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + Just ProgressiveDCT -> + let (st, arr) = decodeProgressive in + dynamicOfColorSpace (colorSpaceOfState st) imgWidth imgHeight arr + _ -> Left "Unkown JPG kind" + where + compCount = length $ jpgComponents scanInfo + (_,scanInfo) = gatherScanInfo img - where compCount = length $ jpgComponents scanInfo - (_,scanInfo) = gatherScanInfo img + imgKind = gatherImageKind $ jpgFrame img + imgWidth = fromIntegral $ jpgWidth scanInfo + imgHeight = fromIntegral $ jpgHeight scanInfo - imgKind = gatherImageKind $ jpgFrame img - imgWidth = fromIntegral $ jpgWidth scanInfo - imgHeight = fromIntegral $ jpgHeight scanInfo + imageSize = imgWidth * imgHeight * compCount - imageSize = imgWidth * imgHeight * compCount - decodeProgressive = runST $ do - let (st, wrotten) = - execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - progressiveUnpack - (maximumHorizontalResolution st, maximumVerticalResolution st) - fHdr - (quantizationMatrices st) - wrotten >>= unsafeFreezeImage + 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) - pixelData = runST $ do - let (st, wrotten) = - execRWS (mapM_ jpgMachineStep (jpgFrame img)) () emptyDecoderState - Just fHdr = currentFrame st - resultImage <- M.new imageSize - let wrapped = MutableImage imgWidth imgHeight resultImage - decodeImage - fHdr - (quantizationMatrices st) - wrotten - wrapped - VS.unsafeFreeze resultImage + + 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 :: Image PixelYCbCr8 -- ^ Source image -> MutableMacroBlock s Int16 -- ^ Mutable block where to put extracted block diff --git a/src/Codec/Picture/Jpg/Common.hs b/src/Codec/Picture/Jpg/Common.hs --- a/src/Codec/Picture/Jpg/Common.hs +++ b/src/Codec/Picture/Jpg/Common.hs @@ -20,7 +20,7 @@ ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<$>), pure ) +import Control.Applicative( pure ) #endif import Control.Applicative( (<$>) ) diff --git a/src/Codec/Picture/Jpg/Types.hs b/src/Codec/Picture/Jpg/Types.hs --- a/src/Codec/Picture/Jpg/Types.hs +++ b/src/Codec/Picture/Jpg/Types.hs @@ -16,13 +16,16 @@ , JpgHuffmanTableSpec( .. ) , JpgImageKind( .. ) , JpgScanSpecification( .. ) + , JpgColorSpace( .. ) + , AdobeTransform( .. ) + , JpgAdobeApp14( .. ) , calculateSize , dctBlockSize ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative( (<*>)) +import Control.Applicative( pure, (<*>)) #endif import Control.Applicative( (<$>) ) @@ -36,6 +39,7 @@ 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 ) @@ -54,6 +58,7 @@ , putWord8 , putWord16be , putLazyByteString + , putByteString ) import Codec.Picture.InternalHelper @@ -96,6 +101,7 @@ data JpgFrame = JpgAppFrame !Word8 B.ByteString + | JpgAdobeAPP14 !JpgAdobeApp14 | JpgExtension !Word8 B.ByteString | JpgQuantTable ![JpgQuantTableSpec] | JpgHuffmanTable ![(JpgHuffmanTableSpec, HuffmanPackedTree)] @@ -104,6 +110,67 @@ | 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 + +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 @@ -288,6 +355,7 @@ getByteString (fromIntegral size - 2) putFrame :: JpgFrame -> Put +putFrame (JpgAdobeAPP14 _adobe) = return () putFrame (JpgAppFrame appCode str) = put (JpgAppSegment appCode) >> putWord16be (fromIntegral $ B.length str) >> put str putFrame (JpgExtension appCode str) = @@ -327,6 +395,12 @@ 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 + parseFrames :: Get [JpgFrame] parseFrames = do kind <- get @@ -340,6 +414,8 @@ case kind of JpgEndOfImage -> return [] + JpgAppSegment 14 -> + parseAdobe14 <$> takeCurrentFrame <*> parseNextFrame JpgAppSegment c -> (\frm lst -> JpgAppFrame c frm : lst) <$> takeCurrentFrame <*> parseNextFrame JpgExtensionSegment c -> @@ -388,7 +464,7 @@ aux JpgStartOfScan = 0xDA aux JpgRestartInterval = 0xDD aux (JpgRestartIntervalEnd v) = v - aux (JpgAppSegment a) = a + aux (JpgAppSegment a) = (a + 0xE0) aux (JpgExtensionSegment a) = a data JpgImageKind = BaseLineDCT | ProgressiveDCT @@ -419,7 +495,7 @@ 0xDB -> JpgQuantizationTable 0xDD -> JpgRestartInterval a | a >= 0xF0 -> JpgExtensionSegment a - | a >= 0xE0 -> JpgAppSegment a + | a >= 0xE0 -> JpgAppSegment (a - 0xE0) | a >= 0xD0 && a <= 0xD7 -> JpgRestartIntervalEnd a | otherwise -> error ("Invalid frame marker (" ++ show a ++ ")") diff --git a/src/Codec/Picture/Types.hs b/src/Codec/Picture/Types.hs --- a/src/Codec/Picture/Types.hs +++ b/src/Codec/Picture/Types.hs @@ -19,6 +19,7 @@ -- ** Image functions , createMutableImage + , newMutableImage , freezeImage , unsafeFreezeImage , thawImage @@ -39,6 +40,7 @@ , PixelCMYK8( .. ) , PixelCMYK16( .. ) , PixelYCbCr8( .. ) + , PixelYCbCrK8( .. ) -- * Type classes , ColorConvertible( .. ) @@ -53,6 +55,7 @@ , pixelMapXY , pixelFold , pixelFoldM + , pixelFoldMap , dynamicMap , dynamicPixelMap @@ -90,6 +93,11 @@ , unsafeWritePixelBetweenAt ) where +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid( Monoid, mempty ) +#endif + +import Data.Monoid( (<>) ) import Control.Monad( foldM, liftM, ap ) import Control.DeepSeq( NFData( .. ) ) import Control.Monad.ST( runST ) @@ -98,7 +106,6 @@ import Foreign.Storable ( Storable ) import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) ) import Data.Word( Word8, Word16, Word32, Word64 ) -import Data.List( foldl' ) import Data.Vector.Storable ( (!) ) import qualified Data.Vector.Storable as V import qualified Data.Vector.Storable.Mutable as M @@ -319,9 +326,19 @@ -> Int -- ^ Height -> px -- ^ Background color -> m (MutableImage (PrimState m) px) +{-# INLINE createMutableImage #-} createMutableImage width height background = unsafeThawImage $ generateImage (\_ _ -> 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` @@ -390,7 +407,7 @@ -- without caring about colorspace, you can use the following snippet. -- -- > dynSquare :: DynamicImage -> DynamicImage --- > dynSquare = dynMap squareImage +-- > dynSquare = dynamicPixelMap squareImage -- > -- > squareImage :: Pixel a => Image a -> Image a -- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge @@ -481,6 +498,22 @@ {-# UNPACK #-} !Pixel8 -- Blue deriving (Eq, Ord, Show) +-- | 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) + -- | Pixel type storing 16bit red, green and blue (RGB) information. -- Values are stored in the following order: -- @@ -724,9 +757,9 @@ where compCount = componentCount (undefined :: a) generated = runST $ 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 + 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 @@ -795,14 +828,23 @@ -- | 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 :: forall acc pixel. (Pixel pixel) => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = - foldl' columnFold initialAccumulator [0 .. h - 1] + columnFold 0 initialAccumulator 0 where - pixelFolder y acc x = f acc x y $ pixelAt img x y - columnFold lineAcc y = foldl' (pixelFolder y) lineAcc [0 .. w - 1] + !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) @@ -817,6 +859,20 @@ 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 -- @@ -1921,14 +1977,109 @@ convertPixel (PixelCMYK8 c m y k) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) where - clampWord8 = fromIntegral . (`unsafeShiftR` 8) - ik :: Int - ik = 255 - fromIntegral k + 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 + 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 v = fromIntegral v + + 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 v = fromIntegral v + + 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 #-}