1-- | Module provides basic types for image manipulation in the library. 2 3{-# LANGUAGE BangPatterns #-} 4{-# LANGUAGE CPP #-} 5{-# LANGUAGE DeriveDataTypeable #-} 6{-# LANGUAGE FlexibleContexts #-} 7{-# LANGUAGE FlexibleInstances #-} 8{-# LANGUAGE FunctionalDependencies #-} 9{-# LANGUAGE MultiParamTypeClasses #-} 10{-# LANGUAGE Rank2Types #-} 11{-# LANGUAGE ScopedTypeVariables #-} 12{-# LANGUAGE TypeFamilies #-} 13{-# LANGUAGE TypeSynonymInstances #-} 14{-# LANGUAGE UndecidableInstances #-} 15-- Defined types are used to store all of those __Juicy Pixels__ 16module Codec.Picture.Types( -- * Types 17 -- ** Image types 18 Image( .. ) 19 , MutableImage( .. ) 20 , DynamicImage( .. ) 21 , PalettedImage( .. ) 22 , Palette 23 , Palette'( .. ) 24 25 -- ** Image functions 26 , createMutableImage 27 , newMutableImage 28 , freezeImage 29 , unsafeFreezeImage 30 , thawImage 31 , unsafeThawImage 32 33 -- ** Image Lenses 34 , Traversal 35 , imagePixels 36 , imageIPixels 37 38 -- ** Pixel types 39 , Pixel8 40 , Pixel16 41 , Pixel32 42 , PixelF 43 , PixelYA8( .. ) 44 , PixelYA16( .. ) 45 , PixelRGB8( .. ) 46 , PixelRGB16( .. ) 47 , PixelRGBF( .. ) 48 , PixelRGBA8( .. ) 49 , PixelRGBA16( .. ) 50 , PixelCMYK8( .. ) 51 , PixelCMYK16( .. ) 52 , PixelYCbCr8( .. ) 53 , PixelYCbCrK8( .. ) 54 55 -- * Type classes 56 , ColorConvertible( .. ) 57 , Pixel(..) 58 -- $graph 59 , ColorSpaceConvertible( .. ) 60 , LumaPlaneExtractable( .. ) 61 , TransparentPixel( .. ) 62 63 -- * Helper functions 64 , pixelMap 65 , pixelMapXY 66 , pixelFold 67 , pixelFoldM 68 , pixelFoldMap 69 70 , dynamicMap 71 , dynamicPixelMap 72 , palettedToTrueColor 73 , palettedAsImage 74 , dropAlphaLayer 75 , withImage 76 , zipPixelComponent3 77 , generateImage 78 , generateFoldImage 79 , gammaCorrection 80 , toneMapping 81 82 -- * Color plane extraction 83 , ColorPlane ( ) 84 85 , PlaneRed( .. ) 86 , PlaneGreen( .. ) 87 , PlaneBlue( .. ) 88 , PlaneAlpha( .. ) 89 , PlaneLuma( .. ) 90 , PlaneCr( .. ) 91 , PlaneCb( .. ) 92 , PlaneCyan( .. ) 93 , PlaneMagenta( .. ) 94 , PlaneYellow( .. ) 95 , PlaneBlack( .. ) 96 97 , extractComponent 98 , unsafeExtractComponent 99 100 -- * Packeable writing (unsafe but faster) 101 , PackeablePixel( .. ) 102 , fillImageWith 103 , readPackedPixelAt 104 , writePackedPixelAt 105 , unsafeWritePixelBetweenAt 106 ) where 107 108#if !MIN_VERSION_base(4,8,0) 109import Data.Monoid( Monoid, mempty ) 110import Control.Applicative( Applicative, pure, (<*>), (<$>) ) 111#endif 112#if !MIN_VERSION_base(4,11,0) 113import Data.Monoid( (<>) ) 114#endif 115import Control.Monad( foldM, liftM, ap ) 116import Control.DeepSeq( NFData( .. ) ) 117import Control.Monad.ST( ST, runST ) 118import Control.Monad.Primitive ( PrimMonad, PrimState ) 119import Foreign.ForeignPtr( castForeignPtr ) 120import Foreign.Storable ( Storable ) 121import Data.Bits( unsafeShiftL, unsafeShiftR, (.|.), (.&.) ) 122import Data.Typeable ( Typeable ) 123import Data.Word( Word8, Word16, Word32, Word64 ) 124import Data.Vector.Storable ( (!) ) 125import qualified Data.Vector.Storable as V 126import qualified Data.Vector.Storable.Mutable as M 127 128#include "ConvGraph.hs" 129 130-- | The main type of this package, one that most 131-- functions work on, is Image. 132-- 133-- Parameterized by the underlying pixel format it 134-- forms a rigid type. If you wish to store images 135-- of different or unknown pixel formats use 'DynamicImage'. 136-- 137-- Image is essentially a rectangular pixel buffer 138-- of specified width and height. The coordinates are 139-- assumed to start from the upper-left corner 140-- of the image, with the horizontal position first 141-- and vertical second. 142data Image a = Image 143 { -- | Width of the image in pixels 144 imageWidth :: {-# UNPACK #-} !Int 145 -- | Height of the image in pixels. 146 , imageHeight :: {-# UNPACK #-} !Int 147 148 -- | Image pixel data. To extract pixels at a given position 149 -- you should use the helper functions. 150 -- 151 -- Internally pixel data is stored as consecutively packed 152 -- lines from top to bottom, scanned from left to right 153 -- within individual lines, from first to last color 154 -- component within each pixel. 155 , imageData :: V.Vector (PixelBaseComponent a) 156 } 157 deriving (Typeable) 158 159instance (Eq (PixelBaseComponent a), Storable (PixelBaseComponent a)) 160 => Eq (Image a) where 161 a == b = imageWidth a == imageWidth b && 162 imageHeight a == imageHeight b && 163 imageData a == imageData b 164 165-- | Type for the palette used in Gif & PNG files. 166type Palette = Image PixelRGB8 167 168-- | Class used to describle plane present in the pixel 169-- type. If a pixel has a plane description associated, 170-- you can use the plane name to extract planes independently. 171class ColorPlane pixel planeToken where 172 -- | Retrieve the index of the component in the 173 -- given pixel type. 174 toComponentIndex :: pixel -> planeToken -> Int 175 176-- | Define the plane for the red color component 177data PlaneRed = PlaneRed 178 deriving (Typeable) 179 180-- | Define the plane for the green color component 181data PlaneGreen = PlaneGreen 182 deriving (Typeable) 183 184-- | Define the plane for the blue color component 185data PlaneBlue = PlaneBlue 186 deriving (Typeable) 187 188-- | Define the plane for the alpha (transparency) component 189data PlaneAlpha = PlaneAlpha 190 deriving (Typeable) 191 192-- | Define the plane for the luma component 193data PlaneLuma = PlaneLuma 194 deriving (Typeable) 195 196-- | Define the plane for the Cr component 197data PlaneCr = PlaneCr 198 deriving (Typeable) 199 200-- | Define the plane for the Cb component 201data PlaneCb = PlaneCb 202 deriving (Typeable) 203 204-- | Define plane for the cyan component of the 205-- CMYK color space. 206data PlaneCyan = PlaneCyan 207 deriving (Typeable) 208 209-- | Define plane for the magenta component of the 210-- CMYK color space. 211data PlaneMagenta = PlaneMagenta 212 deriving (Typeable) 213 214-- | Define plane for the yellow component of the 215-- CMYK color space. 216data PlaneYellow = PlaneYellow 217 deriving (Typeable) 218 219-- | Define plane for the black component of 220-- the CMYK color space. 221data PlaneBlack = PlaneBlack 222 deriving (Typeable) 223 224-- | Extract a color plane from an image given a present plane in the image 225-- examples: 226-- 227-- @ 228-- extractRedPlane :: Image PixelRGB8 -> Image Pixel8 229-- extractRedPlane = extractComponent PlaneRed 230-- @ 231-- 232extractComponent :: forall px plane. ( Pixel px 233 , Pixel (PixelBaseComponent px) 234 , PixelBaseComponent (PixelBaseComponent px) 235 ~ PixelBaseComponent px 236 , ColorPlane px plane ) 237 => plane -> Image px -> Image (PixelBaseComponent px) 238extractComponent plane = unsafeExtractComponent idx 239 where idx = toComponentIndex (undefined :: px) plane 240 241-- | Extract a plane of an image. Returns the requested color 242-- component as a greyscale image. 243-- 244-- If you ask for a component out of bound, the `error` function will 245-- be called. 246unsafeExtractComponent :: forall a 247 . ( Pixel a 248 , Pixel (PixelBaseComponent a) 249 , PixelBaseComponent (PixelBaseComponent a) 250 ~ PixelBaseComponent a) 251 => Int -- ^ The component index, beginning at 0 ending at (componentCount - 1) 252 -> Image a -- ^ Source image 253 -> Image (PixelBaseComponent a) 254unsafeExtractComponent comp img@(Image { imageWidth = w, imageHeight = h }) 255 | comp >= padd = error $ "extractComponent : invalid component index (" 256 ++ show comp ++ ", max:" ++ show padd ++ ")" 257 | otherwise = Image { imageWidth = w, imageHeight = h, imageData = plane } 258 where plane = stride img padd comp 259 padd = componentCount (undefined :: a) 260 261-- | For any image with an alpha component (transparency), 262-- drop it, returning a pure opaque image. 263dropAlphaLayer :: (TransparentPixel a b) => Image a -> Image b 264dropAlphaLayer = pixelMap dropTransparency 265 266-- | Class modeling transparent pixel, should provide a method 267-- to combine transparent pixels 268class (Pixel a, Pixel b) => TransparentPixel a b | a -> b where 269 -- | Just return the opaque pixel value 270 dropTransparency :: a -> b 271 272 -- | access the transparency (alpha layer) of a given 273 -- transparent pixel type. 274 getTransparency :: a -> PixelBaseComponent a 275{-# DEPRECATED getTransparency "please use 'pixelOpacity' instead" #-} 276 277instance TransparentPixel PixelRGBA8 PixelRGB8 where 278 {-# INLINE dropTransparency #-} 279 dropTransparency (PixelRGBA8 r g b _) = PixelRGB8 r g b 280 {-# INLINE getTransparency #-} 281 getTransparency (PixelRGBA8 _ _ _ a) = a 282 283lineFold :: (Monad m) => a -> Int -> (a -> Int -> m a) -> m a 284{-# INLINE lineFold #-} 285lineFold initial count f = go 0 initial 286 where go n acc | n >= count = return acc 287 go n acc = f acc n >>= go (n + 1) 288 289stride :: (Storable (PixelBaseComponent a)) 290 => Image a -> Int -> Int -> V.Vector (PixelBaseComponent a) 291stride Image { imageWidth = w, imageHeight = h, imageData = array } 292 padd firstComponent = runST $ do 293 let cell_count = w * h 294 outArray <- M.new cell_count 295 296 let go writeIndex _ | writeIndex >= cell_count = return () 297 go writeIndex readIndex = do 298 (outArray `M.unsafeWrite` writeIndex) $ array `V.unsafeIndex` readIndex 299 go (writeIndex + 1) $ readIndex + padd 300 301 go 0 firstComponent 302 V.unsafeFreeze outArray 303 304instance NFData (Image a) where 305 rnf (Image width height dat) = width `seq` 306 height `seq` 307 dat `seq` 308 () 309 310-- | Image or pixel buffer, the coordinates are assumed to start 311-- from the upper-left corner of the image, with the horizontal 312-- position first, then the vertical one. The image can be transformed in place. 313data MutableImage s a = MutableImage 314 { -- | Width of the image in pixels 315 mutableImageWidth :: {-# UNPACK #-} !Int 316 317 -- | Height of the image in pixels. 318 , mutableImageHeight :: {-# UNPACK #-} !Int 319 320 -- | The real image, to extract pixels at some position 321 -- you should use the helpers functions. 322 , mutableImageData :: M.STVector s (PixelBaseComponent a) 323 } 324 deriving (Typeable) 325 326-- | `O(n)` Yield an immutable copy of an image by making a copy of it 327freezeImage :: (Storable (PixelBaseComponent px), PrimMonad m) 328 => MutableImage (PrimState m) px -> m (Image px) 329freezeImage (MutableImage w h d) = Image w h `liftM` V.freeze d 330 331-- | `O(n)` Yield a mutable copy of an image by making a copy of it. 332thawImage :: (Storable (PixelBaseComponent px), PrimMonad m) 333 => Image px -> m (MutableImage (PrimState m) px) 334thawImage (Image w h d) = MutableImage w h `liftM` V.thaw d 335 336-- | `O(1)` Unsafe convert an imutable image to an mutable one without copying. 337-- The source image shouldn't be used after this operation. 338unsafeThawImage :: (Storable (PixelBaseComponent px), PrimMonad m) 339 => Image px -> m (MutableImage (PrimState m) px) 340{-# NOINLINE unsafeThawImage #-} 341unsafeThawImage (Image w h d) = MutableImage w h `liftM` V.unsafeThaw d 342 343-- | `O(1)` Unsafe convert a mutable image to an immutable one without copying. 344-- The mutable image may not be used after this operation. 345unsafeFreezeImage :: (Storable (PixelBaseComponent a), PrimMonad m) 346 => MutableImage (PrimState m) a -> m (Image a) 347unsafeFreezeImage (MutableImage w h d) = Image w h `liftM` V.unsafeFreeze d 348 349-- | Create a mutable image, filled with the given background color. 350createMutableImage :: (Pixel px, PrimMonad m) 351 => Int -- ^ Width 352 -> Int -- ^ Height 353 -> px -- ^ Background color 354 -> m (MutableImage (PrimState m) px) 355createMutableImage width height background = 356 generateMutableImage (\_ _ -> background) width height 357 358-- | Create a mutable image with garbage as content. All data 359-- is uninitialized. 360newMutableImage :: forall px m. (Pixel px, PrimMonad m) 361 => Int -- ^ Width 362 -> Int -- ^ Height 363 -> m (MutableImage (PrimState m) px) 364newMutableImage w h = MutableImage w h `liftM` M.new (w * h * compCount) 365 where compCount = componentCount (undefined :: px) 366 367instance NFData (MutableImage s a) where 368 rnf (MutableImage width height dat) = width `seq` 369 height `seq` 370 dat `seq` 371 () 372 373-- | Image type enumerating all predefined pixel types. 374-- It enables loading and use of images of different 375-- pixel types. 376data DynamicImage = 377 -- | A greyscale image. 378 ImageY8 (Image Pixel8) 379 -- | A greyscale image with 16bit components 380 | ImageY16 (Image Pixel16) 381 -- | A greyscale image with 32bit components 382 | ImageY32 (Image Pixel32) 383 -- | A greyscale HDR image 384 | ImageYF (Image PixelF) 385 -- | An image in greyscale with an alpha channel. 386 | ImageYA8 (Image PixelYA8) 387 -- | An image in greyscale with alpha channel on 16 bits. 388 | ImageYA16 (Image PixelYA16) 389 -- | An image in true color. 390 | ImageRGB8 (Image PixelRGB8) 391 -- | An image in true color with 16bit depth. 392 | ImageRGB16 (Image PixelRGB16) 393 -- | An image with HDR pixels 394 | ImageRGBF (Image PixelRGBF) 395 -- | An image in true color and an alpha channel. 396 | ImageRGBA8 (Image PixelRGBA8) 397 -- | A true color image with alpha on 16 bits. 398 | ImageRGBA16 (Image PixelRGBA16) 399 -- | An image in the colorspace used by Jpeg images. 400 | ImageYCbCr8 (Image PixelYCbCr8) 401 -- | An image in the colorspace CMYK 402 | ImageCMYK8 (Image PixelCMYK8) 403 -- | An image in the colorspace CMYK and 16 bits precision 404 | ImageCMYK16 (Image PixelCMYK16) 405 deriving (Eq, Typeable) 406 407-- | Type used to expose a palette extracted during reading. 408-- Use `palettedAsImage` to convert it to a palette usable for 409-- writing. 410data Palette' px = Palette' 411 { -- | Number of element in pixels. 412 _paletteSize :: !Int 413 -- | Real data used by the palette. 414 , _paletteData :: !(V.Vector (PixelBaseComponent px)) 415 } 416 deriving Typeable 417 418-- | Convert a palette to an image. Used mainly for 419-- backward compatibility. 420palettedAsImage :: Palette' px -> Image px 421palettedAsImage p = Image (_paletteSize p) 1 $ _paletteData p 422 423-- | Describe an image and it's potential associated 424-- palette. If no palette is present, fallback to a 425-- DynamicImage 426data PalettedImage 427 = TrueColorImage DynamicImage -- ^ Fallback 428 | PalettedY8 (Image Pixel8) (Palette' Pixel8) 429 | PalettedRGB8 (Image Pixel8) (Palette' PixelRGB8) 430 | PalettedRGBA8 (Image Pixel8) (Palette' PixelRGBA8) 431 | PalettedRGB16 (Image Pixel8) (Palette' PixelRGB16) 432 deriving (Typeable) 433 434-- | Flatten a PalettedImage to a DynamicImage 435palettedToTrueColor :: PalettedImage -> DynamicImage 436palettedToTrueColor img = case img of 437 TrueColorImage d -> d 438 PalettedY8 i p -> ImageY8 $ toTrueColor 1 (_paletteData p) i 439 PalettedRGB8 i p -> ImageRGB8 $ toTrueColor 3 (_paletteData p) i 440 PalettedRGBA8 i p -> ImageRGBA8 $ toTrueColor 4 (_paletteData p) i 441 PalettedRGB16 i p -> ImageRGB16 $ toTrueColor 3 (_paletteData p) i 442 where 443 toTrueColor c vec = pixelMap (unsafePixelAt vec . (c *) . fromIntegral) 444 445-- | Helper function to help extract information from dynamic 446-- image. To get the width of a dynamic image, you can use 447-- the following snippet: 448-- 449-- > dynWidth :: DynamicImage -> Int 450-- > dynWidth img = dynamicMap imageWidth img 451-- 452dynamicMap :: (forall pixel . (Pixel pixel) => Image pixel -> a) 453 -> DynamicImage -> a 454dynamicMap f (ImageY8 i) = f i 455dynamicMap f (ImageY16 i) = f i 456dynamicMap f (ImageY32 i) = f i 457dynamicMap f (ImageYF i) = f i 458dynamicMap f (ImageYA8 i) = f i 459dynamicMap f (ImageYA16 i) = f i 460dynamicMap f (ImageRGB8 i) = f i 461dynamicMap f (ImageRGB16 i) = f i 462dynamicMap f (ImageRGBF i) = f i 463dynamicMap f (ImageRGBA8 i) = f i 464dynamicMap f (ImageRGBA16 i) = f i 465dynamicMap f (ImageYCbCr8 i) = f i 466dynamicMap f (ImageCMYK8 i) = f i 467dynamicMap f (ImageCMYK16 i) = f i 468 469-- | Equivalent of the `pixelMap` function for the dynamic images. 470-- You can perform pixel colorspace independant operations with this 471-- function. 472-- 473-- For instance, if you want to extract a square crop of any image, 474-- without caring about colorspace, you can use the following snippet. 475-- 476-- > dynSquare :: DynamicImage -> DynamicImage 477-- > dynSquare = dynamicPixelMap squareImage 478-- > 479-- > squareImage :: Pixel a => Image a -> Image a 480-- > squareImage img = generateImage (\x y -> pixelAt img x y) edge edge 481-- > where edge = min (imageWidth img) (imageHeight img) 482-- 483dynamicPixelMap :: (forall pixel . (Pixel pixel) => Image pixel -> Image pixel) 484 -> DynamicImage -> DynamicImage 485dynamicPixelMap f = aux 486 where 487 aux (ImageY8 i) = ImageY8 (f i) 488 aux (ImageY16 i) = ImageY16 (f i) 489 aux (ImageY32 i) = ImageY32 (f i) 490 aux (ImageYF i) = ImageYF (f i) 491 aux (ImageYA8 i) = ImageYA8 (f i) 492 aux (ImageYA16 i) = ImageYA16 (f i) 493 aux (ImageRGB8 i) = ImageRGB8 (f i) 494 aux (ImageRGB16 i) = ImageRGB16 (f i) 495 aux (ImageRGBF i) = ImageRGBF (f i) 496 aux (ImageRGBA8 i) = ImageRGBA8 (f i) 497 aux (ImageRGBA16 i) = ImageRGBA16 (f i) 498 aux (ImageYCbCr8 i) = ImageYCbCr8 (f i) 499 aux (ImageCMYK8 i) = ImageCMYK8 (f i) 500 aux (ImageCMYK16 i) = ImageCMYK16 (f i) 501 502instance NFData DynamicImage where 503 rnf (ImageY8 img) = rnf img 504 rnf (ImageY16 img) = rnf img 505 rnf (ImageY32 img) = rnf img 506 rnf (ImageYF img) = rnf img 507 rnf (ImageYA8 img) = rnf img 508 rnf (ImageYA16 img) = rnf img 509 rnf (ImageRGB8 img) = rnf img 510 rnf (ImageRGB16 img) = rnf img 511 rnf (ImageRGBF img) = rnf img 512 rnf (ImageRGBA8 img) = rnf img 513 rnf (ImageRGBA16 img) = rnf img 514 rnf (ImageYCbCr8 img) = rnf img 515 rnf (ImageCMYK8 img) = rnf img 516 rnf (ImageCMYK16 img) = rnf img 517 518-- | Type alias for 8bit greyscale pixels. For simplicity, 519-- greyscale pixels use plain numbers instead of a separate type. 520type Pixel8 = Word8 521 522-- | Type alias for 16bit greyscale pixels. 523type Pixel16 = Word16 524 525-- | Type alias for 32bit greyscale pixels. 526type Pixel32 = Word32 527 528-- | Type alias for 32bit floating point greyscale pixels. The standard 529-- bounded value range is mapped to the closed interval [0,1] i.e. 530-- 531-- > map promotePixel [0, 1 .. 255 :: Pixel8] == [0/255, 1/255 .. 1.0 :: PixelF] 532type PixelF = Float 533 534-- | Pixel type storing 8bit Luminance (Y) and alpha (A) information. 535-- Values are stored in the following order: 536-- 537-- * Luminance 538-- 539-- * Alpha 540-- 541data PixelYA8 = PixelYA8 {-# UNPACK #-} !Pixel8 -- Luminance 542 {-# UNPACK #-} !Pixel8 -- Alpha value 543 deriving (Eq, Ord, Show, Typeable) 544 545-- | Pixel type storing 16bit Luminance (Y) and alpha (A) information. 546-- Values are stored in the following order: 547-- 548-- * Luminance 549-- 550-- * Alpha 551-- 552data PixelYA16 = PixelYA16 {-# UNPACK #-} !Pixel16 -- Luminance 553 {-# UNPACK #-} !Pixel16 -- Alpha value 554 deriving (Eq, Ord, Show, Typeable) 555 556-- | Classic pixel type storing 8bit red, green and blue (RGB) information. 557-- Values are stored in the following order: 558-- 559-- * Red 560-- 561-- * Green 562-- 563-- * Blue 564-- 565data PixelRGB8 = PixelRGB8 {-# UNPACK #-} !Pixel8 -- Red 566 {-# UNPACK #-} !Pixel8 -- Green 567 {-# UNPACK #-} !Pixel8 -- Blue 568 deriving (Eq, Ord, Show, Typeable) 569 570-- | Pixel type storing value for the YCCK color space: 571-- 572-- * Y (Luminance) 573-- 574-- * Cb 575-- 576-- * Cr 577-- 578-- * Black 579-- 580data PixelYCbCrK8 = PixelYCbCrK8 {-# UNPACK #-} !Pixel8 581 {-# UNPACK #-} !Pixel8 582 {-# UNPACK #-} !Pixel8 583 {-# UNPACK #-} !Pixel8 584 deriving (Eq, Ord, Show, Typeable) 585 586-- | Pixel type storing 16bit red, green and blue (RGB) information. 587-- Values are stored in the following order: 588-- 589-- * Red 590-- 591-- * Green 592-- 593-- * Blue 594-- 595data PixelRGB16 = PixelRGB16 {-# UNPACK #-} !Pixel16 -- Red 596 {-# UNPACK #-} !Pixel16 -- Green 597 {-# UNPACK #-} !Pixel16 -- Blue 598 deriving (Eq, Ord, Show, Typeable) 599 600-- | HDR pixel type storing floating point 32bit red, green and blue (RGB) information. 601-- Same value range and comments apply as for 'PixelF'. 602-- Values are stored in the following order: 603-- 604-- * Red 605-- 606-- * Green 607-- 608-- * Blue 609-- 610data PixelRGBF = PixelRGBF {-# UNPACK #-} !PixelF -- Red 611 {-# UNPACK #-} !PixelF -- Green 612 {-# UNPACK #-} !PixelF -- Blue 613 deriving (Eq, Ord, Show, Typeable) 614 615-- | Pixel type storing 8bit luminance, blue difference and red difference (YCbCr) information. 616-- Values are stored in the following order: 617-- 618-- * Y (luminance) 619-- 620-- * Cb 621-- 622-- * Cr 623-- 624data PixelYCbCr8 = PixelYCbCr8 {-# UNPACK #-} !Pixel8 -- Y luminance 625 {-# UNPACK #-} !Pixel8 -- Cb blue difference 626 {-# UNPACK #-} !Pixel8 -- Cr red difference 627 deriving (Eq, Ord, Show, Typeable) 628 629-- | Pixel type storing 8bit cyan, magenta, yellow and black (CMYK) information. 630-- Values are stored in the following order: 631-- 632-- * Cyan 633-- 634-- * Magenta 635-- 636-- * Yellow 637-- 638-- * Black 639-- 640data PixelCMYK8 = PixelCMYK8 {-# UNPACK #-} !Pixel8 -- Cyan 641 {-# UNPACK #-} !Pixel8 -- Magenta 642 {-# UNPACK #-} !Pixel8 -- Yellow 643 {-# UNPACK #-} !Pixel8 -- Black 644 deriving (Eq, Ord, Show, Typeable) 645 646-- | Pixel type storing 16bit cyan, magenta, yellow and black (CMYK) information. 647-- Values are stored in the following order: 648-- 649-- * Cyan 650-- 651-- * Magenta 652-- 653-- * Yellow 654-- 655-- * Black 656-- 657data PixelCMYK16 = PixelCMYK16 {-# UNPACK #-} !Pixel16 -- Cyan 658 {-# UNPACK #-} !Pixel16 -- Magenta 659 {-# UNPACK #-} !Pixel16 -- Yellow 660 {-# UNPACK #-} !Pixel16 -- Black 661 deriving (Eq, Ord, Show, Typeable) 662 663 664-- | Classical pixel type storing 8bit red, green, blue and alpha (RGBA) information. 665-- Values are stored in the following order: 666-- 667-- * Red 668-- 669-- * Green 670-- 671-- * Blue 672-- 673-- * Alpha 674-- 675data PixelRGBA8 = PixelRGBA8 {-# UNPACK #-} !Pixel8 -- Red 676 {-# UNPACK #-} !Pixel8 -- Green 677 {-# UNPACK #-} !Pixel8 -- Blue 678 {-# UNPACK #-} !Pixel8 -- Alpha 679 deriving (Eq, Ord, Show, Typeable) 680 681-- | Pixel type storing 16bit red, green, blue and alpha (RGBA) information. 682-- Values are stored in the following order: 683-- 684-- * Red 685-- 686-- * Green 687-- 688-- * Blue 689-- 690-- * Alpha 691-- 692data PixelRGBA16 = PixelRGBA16 {-# UNPACK #-} !Pixel16 -- Red 693 {-# UNPACK #-} !Pixel16 -- Green 694 {-# UNPACK #-} !Pixel16 -- Blue 695 {-# UNPACK #-} !Pixel16 -- Alpha 696 deriving (Eq, Ord, Show, Typeable) 697 698-- | Definition of pixels used in images. Each pixel has a color space, and a representative 699-- component (Word8 or Float). 700class ( Storable (PixelBaseComponent a) 701 , Num (PixelBaseComponent a), Eq a ) => Pixel a where 702 -- | Type of the pixel component, "classical" images 703 -- would have Word8 type as their PixelBaseComponent, 704 -- HDR image would have Float for instance 705 type PixelBaseComponent a :: * 706 707 -- | Call the function for every component of the pixels. 708 -- For example for RGB pixels mixWith is declared like this: 709 -- 710 -- > mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = 711 -- > PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) 712 -- 713 mixWith :: (Int -> PixelBaseComponent a -> PixelBaseComponent a -> PixelBaseComponent a) 714 -> a -> a -> a 715 716 -- | Extension of the `mixWith` which separate the treatment 717 -- of the color components of the alpha value (transparency component). 718 -- For pixel without alpha components, it is equivalent to mixWith. 719 -- 720 -- > mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGB8 rb gb bb ab) = 721 -- > PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) 722 -- 723 mixWithAlpha :: (Int -> PixelBaseComponent a -> PixelBaseComponent a 724 -> PixelBaseComponent a) -- ^ Function for color component 725 -> (PixelBaseComponent a -> PixelBaseComponent a 726 -> PixelBaseComponent a) -- ^ Function for alpha component 727 -> a -> a -> a 728 {-# INLINE mixWithAlpha #-} 729 mixWithAlpha f _ = mixWith f 730 731 -- | Return the opacity of a pixel, if the pixel has an 732 -- alpha layer, return the alpha value. If the pixel 733 -- doesn't have an alpha value, return a value 734 -- representing the opaqueness. 735 pixelOpacity :: a -> PixelBaseComponent a 736 737 -- | Return the number of components of the pixel 738 componentCount :: a -> Int 739 740 -- | Apply a function to each component of a pixel. 741 -- If the color type possess an alpha (transparency channel), 742 -- it is treated like the other color components. 743 colorMap :: (PixelBaseComponent a -> PixelBaseComponent a) -> a -> a 744 745 -- | Calculate the index for the begining of the pixel 746 pixelBaseIndex :: Image a -> Int -> Int -> Int 747 pixelBaseIndex (Image { imageWidth = w }) x y = 748 (x + y * w) * componentCount (undefined :: a) 749 750 -- | Calculate theindex for the begining of the pixel at position x y 751 mutablePixelBaseIndex :: MutableImage s a -> Int -> Int -> Int 752 mutablePixelBaseIndex (MutableImage { mutableImageWidth = w }) x y = 753 (x + y * w) * componentCount (undefined :: a) 754 755 -- | Extract a pixel at a given position, (x, y), the origin 756 -- is assumed to be at the corner top left, positive y to the 757 -- bottom of the image 758 pixelAt :: Image a -> Int -> Int -> a 759 760 -- | Same as pixelAt but for mutable images. 761 readPixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> m a 762 763 -- | Write a pixel in a mutable image at position x y 764 writePixel :: PrimMonad m => MutableImage (PrimState m) a -> Int -> Int -> a -> m () 765 766 -- | Unsafe version of pixelAt, read a pixel at the given 767 -- index without bound checking (if possible). 768 -- The index is expressed in number (PixelBaseComponent a) 769 unsafePixelAt :: V.Vector (PixelBaseComponent a) -> Int -> a 770 771 -- | Unsafe version of readPixel, read a pixel at the given 772 -- position without bound checking (if possible). The index 773 -- is expressed in number (PixelBaseComponent a) 774 unsafeReadPixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> m a 775 776 -- | Unsafe version of writePixel, write a pixel at the 777 -- given position without bound checking. This can be _really_ unsafe. 778 -- The index is expressed in number (PixelBaseComponent a) 779 unsafeWritePixel :: PrimMonad m => M.STVector (PrimState m) (PixelBaseComponent a) -> Int -> a -> m () 780 781 782-- | Implement upcasting for pixel types. 783-- Minimal declaration of `promotePixel`. 784-- It is strongly recommended to overload promoteImage to keep 785-- performance acceptable 786class (Pixel a, Pixel b) => ColorConvertible a b where 787 -- | Convert a pixel type to another pixel type. This 788 -- operation should never lose any data. 789 promotePixel :: a -> b 790 791 -- | Change the underlying pixel type of an image by performing a full copy 792 -- of it. 793 promoteImage :: Image a -> Image b 794 promoteImage = pixelMap promotePixel 795 796-- | This class abstract colorspace conversion. This 797-- conversion can be lossy, which ColorConvertible cannot 798class (Pixel a, Pixel b) => ColorSpaceConvertible a b where 799 -- | Pass a pixel from a colorspace (say RGB) to the second one 800 -- (say YCbCr) 801 convertPixel :: a -> b 802 803 -- | Helper function to convert a whole image by taking a 804 -- copy it. 805 convertImage :: Image a -> Image b 806 convertImage = pixelMap convertPixel 807 808generateMutableImage :: forall m px. (Pixel px, PrimMonad m) 809 => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. 810 -> Int -- ^ Width in pixels 811 -> Int -- ^ Height in pixels 812 -> m (MutableImage (PrimState m) px) 813{-# INLINE generateMutableImage #-} 814generateMutableImage f w h = MutableImage w h `liftM` generated where 815 compCount = componentCount (undefined :: px) 816 817 generated = do 818 arr <- M.new (w * h * compCount) 819 let lineGenerator _ !y | y >= h = return () 820 lineGenerator !lineIdx y = column lineIdx 0 821 where column !idx !x | x >= w = lineGenerator idx $ y + 1 822 column idx x = do 823 unsafeWritePixel arr idx $ f x y 824 column (idx + compCount) $ x + 1 825 lineGenerator 0 0 826 return arr 827 828-- | Create an image given a function to generate pixels. 829-- The function will receive values from 0 to width-1 for the x parameter 830-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper 831-- left corner of the image, and (width-1, height-1) the lower right corner. 832-- 833-- for example, to create a small gradient image: 834-- 835-- > imageCreator :: String -> IO () 836-- > imageCreator path = writePng path $ generateImage pixelRenderer 250 300 837-- > where pixelRenderer x y = PixelRGB8 (fromIntegral x) (fromIntegral y) 128 838-- 839generateImage :: forall px. (Pixel px) 840 => (Int -> Int -> px) -- ^ Generating function, with `x` and `y` params. 841 -> Int -- ^ Width in pixels 842 -> Int -- ^ Height in pixels 843 -> Image px 844{-# INLINE generateImage #-} 845generateImage f w h = runST img where 846 img :: ST s (Image px) 847 img = generateMutableImage f w h >>= unsafeFreezeImage 848 849-- | Create an image using a monadic initializer function. 850-- The function will receive values from 0 to width-1 for the x parameter 851-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper 852-- left corner of the image, and (width-1, height-1) the lower right corner. 853-- 854-- The function is called for each pixel in the line from left to right (0 to width - 1) 855-- and for each line (0 to height - 1). 856withImage :: forall m pixel. (Pixel pixel, PrimMonad m) 857 => Int -- ^ Image width 858 -> Int -- ^ Image height 859 -> (Int -> Int -> m pixel) -- ^ Generating functions 860 -> m (Image pixel) 861withImage width height pixelGenerator = do 862 let pixelComponentCount = componentCount (undefined :: pixel) 863 arr <- M.new (width * height * pixelComponentCount) 864 let mutImage = MutableImage 865 { mutableImageWidth = width 866 , mutableImageHeight = height 867 , mutableImageData = arr 868 } 869 870 let pixelPositions = [(x, y) | y <- [0 .. height-1], x <- [0..width-1]] 871 sequence_ [pixelGenerator x y >>= unsafeWritePixel arr idx 872 | ((x,y), idx) <- zip pixelPositions [0, pixelComponentCount ..]] 873 unsafeFreezeImage mutImage 874 875-- | Create an image given a function to generate pixels. 876-- The function will receive values from 0 to width-1 for the x parameter 877-- and 0 to height-1 for the y parameter. The coordinates 0,0 are the upper 878-- left corner of the image, and (width-1, height-1) the lower right corner. 879-- 880-- the acc parameter is a user defined one. 881-- 882-- The function is called for each pixel in the line from left to right (0 to width - 1) 883-- and for each line (0 to height - 1). 884generateFoldImage :: forall a acc. (Pixel a) 885 => (acc -> Int -> Int -> (acc, a)) -- ^ Function taking the state, x and y 886 -> acc -- ^ Initial state 887 -> Int -- ^ Width in pixels 888 -> Int -- ^ Height in pixels 889 -> (acc, Image a) 890generateFoldImage f intialAcc w h = 891 (finalState, Image { imageWidth = w, imageHeight = h, imageData = generated }) 892 where compCount = componentCount (undefined :: a) 893 (finalState, generated) = runST $ do 894 arr <- M.new (w * h * compCount) 895 let mutImage = MutableImage { 896 mutableImageWidth = w, 897 mutableImageHeight = h, 898 mutableImageData = arr } 899 foldResult <- foldM (\acc (x,y) -> do 900 let (acc', px) = f acc x y 901 writePixel mutImage x y px 902 return acc') intialAcc [(x,y) | y <- [0 .. h-1], x <- [0 .. w-1]] 903 904 frozen <- V.unsafeFreeze arr 905 return (foldResult, frozen) 906 907-- | Fold over the pixel of an image with a raster scan order: 908-- from top to bottom, left to right 909{-# INLINE pixelFold #-} 910pixelFold :: forall acc pixel. (Pixel pixel) 911 => (acc -> Int -> Int -> pixel -> acc) -> acc -> Image pixel -> acc 912pixelFold f initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = 913 columnFold 0 initialAccumulator 0 914 where 915 !compCount = componentCount (undefined :: pixel) 916 !vec = imageData img 917 918 lfold !y acc !x !idx 919 | x >= w = columnFold (y + 1) acc idx 920 | otherwise = 921 lfold y (f acc x y $ unsafePixelAt vec idx) (x + 1) (idx + compCount) 922 923 columnFold !y lineAcc !readIdx 924 | y >= h = lineAcc 925 | otherwise = lfold y lineAcc 0 readIdx 926 927-- | Fold over the pixel of an image with a raster scan order: 928-- from top to bottom, left to right, carrying out a state 929pixelFoldM :: (Pixel pixel, Monad m) 930 => (acc -> Int -> Int -> pixel -> m acc) -- ^ monadic mapping function 931 -> acc -- ^ Initial state 932 -> Image pixel -- ^ Image to fold over 933 -> m acc 934{-# INLINE pixelFoldM #-} 935pixelFoldM action initialAccumulator img@(Image { imageWidth = w, imageHeight = h }) = 936 lineFold initialAccumulator h columnFold 937 where 938 pixelFolder y acc x = action acc x y $ pixelAt img x y 939 columnFold lineAcc y = lineFold lineAcc w (pixelFolder y) 940 941 942-- | Fold over the pixel of an image with a raster scan order: 943-- from top to bottom, left to right. This functions is analog 944-- to the foldMap from the 'Foldable' typeclass, but due to the 945-- Pixel constraint, Image cannot be made an instance of it. 946pixelFoldMap :: forall m px. (Pixel px, Monoid m) => (px -> m) -> Image px -> m 947pixelFoldMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = folder 0 948 where 949 compCount = componentCount (undefined :: px) 950 maxi = w * h * compCount 951 952 folder idx | idx >= maxi = mempty 953 folder idx = f (unsafePixelAt vec idx) <> folder (idx + compCount) 954 955-- | `map` equivalent for an image, working at the pixel level. 956-- Little example : a brightness function for an rgb image 957-- 958-- > brightnessRGB8 :: Int -> Image PixelRGB8 -> Image PixelRGB8 959-- > brightnessRGB8 add = pixelMap brightFunction 960-- > where up v = fromIntegral (fromIntegral v + add) 961-- > brightFunction (PixelRGB8 r g b) = 962-- > PixelRGB8 (up r) (up g) (up b) 963-- 964pixelMap :: forall a b. (Pixel a, Pixel b) 965 => (a -> b) -> Image a -> Image b 966{-# SPECIALIZE INLINE pixelMap :: (PixelYCbCr8 -> PixelRGB8) -> Image PixelYCbCr8 -> Image PixelRGB8 #-} 967{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelYCbCr8) -> Image PixelRGB8 -> Image PixelYCbCr8 #-} 968{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGB8) -> Image PixelRGB8 -> Image PixelRGB8 #-} 969{-# SPECIALIZE INLINE pixelMap :: (PixelRGB8 -> PixelRGBA8) -> Image PixelRGB8 -> Image PixelRGBA8 #-} 970{-# SPECIALIZE INLINE pixelMap :: (PixelRGBA8 -> PixelRGBA8) -> Image PixelRGBA8 -> Image PixelRGBA8 #-} 971{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> PixelRGB8) -> Image Pixel8 -> Image PixelRGB8 #-} 972{-# SPECIALIZE INLINE pixelMap :: (Pixel8 -> Pixel8) -> Image Pixel8 -> Image Pixel8 #-} 973pixelMap f Image { imageWidth = w, imageHeight = h, imageData = vec } = 974 Image w h pixels 975 where sourceComponentCount = componentCount (undefined :: a) 976 destComponentCount = componentCount (undefined :: b) 977 978 pixels = runST $ do 979 newArr <- M.new (w * h * destComponentCount) 980 let lineMapper _ _ y | y >= h = return () 981 lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 982 where colMapper readIdx writeIdx x 983 | x >= w = lineMapper readIdx writeIdx $ y + 1 984 | otherwise = do 985 unsafeWritePixel newArr writeIdx . f $ unsafePixelAt vec readIdx 986 colMapper (readIdx + sourceComponentCount) 987 (writeIdx + destComponentCount) 988 (x + 1) 989 lineMapper 0 0 0 990 991 -- unsafeFreeze avoids making a second copy and it will be 992 -- safe because newArray can't be referenced as a mutable array 993 -- outside of this where block 994 V.unsafeFreeze newArr 995 996 997-- | Helpers to embed a rankNTypes inside an Applicative 998newtype GenST a = GenST { genAction :: forall s. ST s (M.STVector s a) } 999 1000-- | Traversal type matching the definition in the Lens package. 1001type Traversal s t a b = 1002 forall f. Applicative f => (a -> f b) -> s -> f t 1003 1004writePx :: Pixel px 1005 => Int -> GenST (PixelBaseComponent px) -> px -> GenST (PixelBaseComponent px) 1006{-# INLINE writePx #-} 1007writePx idx act px = GenST $ do 1008 vec <- genAction act 1009 unsafeWritePixel vec idx px 1010 return vec 1011 1012freezeGenST :: Pixel px 1013 => Int -> Int -> GenST (PixelBaseComponent px) -> Image px 1014freezeGenST w h act = 1015 Image w h (runST (genAction act >>= V.unsafeFreeze)) 1016 1017-- | Traversal in "raster" order, from left to right the top to bottom. 1018-- This traversal is matching pixelMap in spirit. 1019-- 1020-- Since 3.2.4 1021imagePixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) 1022 => Traversal (Image pxa) (Image pxb) pxa pxb 1023{-# INLINE imagePixels #-} 1024imagePixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = 1025 freezeGenST w h <$> pixels 1026 where 1027 sourceComponentCount = componentCount (undefined :: pxa) 1028 destComponentCount = componentCount (undefined :: pxb) 1029 1030 maxi = w * h * sourceComponentCount 1031 pixels = 1032 go (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 1033 1034 go act readIdx _ | readIdx >= maxi = act 1035 go act readIdx writeIdx = 1036 go newAct (readIdx + sourceComponentCount) (writeIdx + destComponentCount) 1037 where 1038 px = f (unsafePixelAt vec readIdx) 1039 newAct = writePx writeIdx <$> act <*> px 1040 1041-- | Traversal providing the pixel position with it's value. 1042-- The traversal in raster order, from lef to right, then top 1043-- to bottom. The traversal match pixelMapXY in spirit. 1044-- 1045-- Since 3.2.4 1046imageIPixels :: forall pxa pxb. (Pixel pxa, Pixel pxb) 1047 => Traversal (Image pxa) (Image pxb) (Int, Int, pxa) pxb 1048{-# INLINE imageIPixels #-} 1049imageIPixels f Image { imageWidth = w, imageHeight = h, imageData = vec } = 1050 freezeGenST w h <$> pixels 1051 where 1052 sourceComponentCount = componentCount (undefined :: pxa) 1053 destComponentCount = componentCount (undefined :: pxb) 1054 1055 pixels = 1056 lineMapper (pure $ GenST $ M.new (w * h * destComponentCount)) 0 0 0 1057 1058 lineMapper act _ _ y | y >= h = act 1059 lineMapper act readIdxLine writeIdxLine y = 1060 go act readIdxLine writeIdxLine 0 1061 where 1062 go cact readIdx writeIdx x 1063 | x >= w = lineMapper cact readIdx writeIdx $ y + 1 1064 | otherwise = do 1065 let px = f (x, y, unsafePixelAt vec readIdx) 1066 go (writePx writeIdx <$> cact <*> px) 1067 (readIdx + sourceComponentCount) 1068 (writeIdx + destComponentCount) 1069 (x + 1) 1070 1071-- | Just like `pixelMap` only the function takes the pixel coordinates as 1072-- additional parameters. 1073pixelMapXY :: forall a b. (Pixel a, Pixel b) 1074 => (Int -> Int -> a -> b) -> Image a -> Image b 1075{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelYCbCr8 -> PixelRGB8) 1076 -> Image PixelYCbCr8 -> Image PixelRGB8 #-} 1077{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelYCbCr8) 1078 -> Image PixelRGB8 -> Image PixelYCbCr8 #-} 1079{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGB8) 1080 -> Image PixelRGB8 -> Image PixelRGB8 #-} 1081{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGB8 -> PixelRGBA8) 1082 -> Image PixelRGB8 -> Image PixelRGBA8 #-} 1083{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> PixelRGBA8 -> PixelRGBA8) 1084 -> Image PixelRGBA8 -> Image PixelRGBA8 #-} 1085{-# SPECIALIZE INLINE pixelMapXY :: (Int -> Int -> Pixel8 -> PixelRGB8) 1086 -> Image Pixel8 -> Image PixelRGB8 #-} 1087pixelMapXY f Image { imageWidth = w, imageHeight = h, imageData = vec } = 1088 Image w h pixels 1089 where sourceComponentCount = componentCount (undefined :: a) 1090 destComponentCount = componentCount (undefined :: b) 1091 1092 pixels = runST $ do 1093 newArr <- M.new (w * h * destComponentCount) 1094 let lineMapper _ _ y | y >= h = return () 1095 lineMapper readIdxLine writeIdxLine y = colMapper readIdxLine writeIdxLine 0 1096 where colMapper readIdx writeIdx x 1097 | x >= w = lineMapper readIdx writeIdx $ y + 1 1098 | otherwise = do 1099 unsafeWritePixel newArr writeIdx . f x y $ unsafePixelAt vec readIdx 1100 colMapper (readIdx + sourceComponentCount) 1101 (writeIdx + destComponentCount) 1102 (x + 1) 1103 lineMapper 0 0 0 1104 1105 -- unsafeFreeze avoids making a second copy and it will be 1106 -- safe because newArray can't be referenced as a mutable array 1107 -- outside of this where block 1108 V.unsafeFreeze newArr 1109 1110-- | Combine, pixel by pixel and component by component 1111-- the values of 3 different images. Usage example: 1112-- 1113-- > averageBrightNess c1 c2 c3 = clamp $ toInt c1 + toInt c2 + toInt c3 1114-- > where clamp = fromIntegral . min 0 . max 255 1115-- > toInt :: a -> Int 1116-- > toInt = fromIntegral 1117-- > ziPixelComponent3 averageBrightNess img1 img2 img3 1118-- 1119zipPixelComponent3 1120 :: forall px. ( V.Storable (PixelBaseComponent px)) 1121 => (PixelBaseComponent px -> PixelBaseComponent px -> PixelBaseComponent px 1122 -> PixelBaseComponent px) 1123 -> Image px -> Image px -> Image px -> Image px 1124{-# INLINE zipPixelComponent3 #-} 1125zipPixelComponent3 f i1@(Image { imageWidth = w, imageHeight = h }) i2 i3 1126 | not isDimensionEqual = error "Different image size zipPairwisePixelComponent" 1127 | otherwise = Image { imageWidth = w 1128 , imageHeight = h 1129 , imageData = V.zipWith3 f data1 data2 data3 1130 } 1131 where data1 = imageData i1 1132 data2 = imageData i2 1133 data3 = imageData i3 1134 1135 isDimensionEqual = 1136 w == imageWidth i2 && w == imageWidth i3 && 1137 h == imageHeight i2 && h == imageHeight i3 1138 1139-- | Helper class to help extract a luma plane out 1140-- of an image or a pixel 1141class (Pixel a, Pixel (PixelBaseComponent a)) => LumaPlaneExtractable a where 1142 -- | Compute the luminance part of a pixel 1143 computeLuma :: a -> PixelBaseComponent a 1144 1145 -- | Extract a luma plane out of an image. This 1146 -- method is in the typeclass to help performant 1147 -- implementation. 1148 -- 1149 -- > jpegToGrayScale :: FilePath -> FilePath -> IO () 1150 -- > jpegToGrayScale source dest 1151 extractLumaPlane :: Image a -> Image (PixelBaseComponent a) 1152 extractLumaPlane = pixelMap computeLuma 1153 1154instance LumaPlaneExtractable Pixel8 where 1155 {-# INLINE computeLuma #-} 1156 computeLuma = id 1157 extractLumaPlane = id 1158 1159instance LumaPlaneExtractable Pixel16 where 1160 {-# INLINE computeLuma #-} 1161 computeLuma = id 1162 extractLumaPlane = id 1163 1164instance LumaPlaneExtractable Pixel32 where 1165 {-# INLINE computeLuma #-} 1166 computeLuma = id 1167 extractLumaPlane = id 1168 1169instance LumaPlaneExtractable PixelF where 1170 {-# INLINE computeLuma #-} 1171 computeLuma = id 1172 extractLumaPlane = id 1173 1174instance LumaPlaneExtractable PixelRGBF where 1175 {-# INLINE computeLuma #-} 1176 computeLuma (PixelRGBF r g b) = 1177 0.3 * r + 0.59 * g + 0.11 * b 1178 1179instance LumaPlaneExtractable PixelRGBA8 where 1180 {-# INLINE computeLuma #-} 1181 computeLuma (PixelRGBA8 r g b _) = 1182 floor $ (0.3 :: Double) * fromIntegral r 1183 + 0.59 * fromIntegral g 1184 + 0.11 * fromIntegral b 1185 1186instance LumaPlaneExtractable PixelYCbCr8 where 1187 {-# INLINE computeLuma #-} 1188 computeLuma (PixelYCbCr8 y _ _) = y 1189 extractLumaPlane = extractComponent PlaneLuma 1190 1191-- | Free promotion for identic pixel types 1192instance (Pixel a) => ColorConvertible a a where 1193 {-# INLINE promotePixel #-} 1194 promotePixel = id 1195 1196 {-# INLINE promoteImage #-} 1197 promoteImage = id 1198 1199-------------------------------------------------- 1200---- Pixel8 instances 1201-------------------------------------------------- 1202instance Pixel Pixel8 where 1203 type PixelBaseComponent Pixel8 = Word8 1204 1205 {-# INLINE pixelOpacity #-} 1206 pixelOpacity = const maxBound 1207 1208 {-# INLINE mixWith #-} 1209 mixWith f = f 0 1210 1211 {-# INLINE colorMap #-} 1212 colorMap f = f 1213 1214 {-# INLINE componentCount #-} 1215 componentCount _ = 1 1216 1217 {-# INLINE pixelAt #-} 1218 pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) 1219 1220 {-# INLINE readPixel #-} 1221 readPixel image@(MutableImage { mutableImageData = arr }) x y = 1222 arr `M.read` mutablePixelBaseIndex image x y 1223 1224 {-# INLINE writePixel #-} 1225 writePixel image@(MutableImage { mutableImageData = arr }) x y = 1226 arr `M.write` mutablePixelBaseIndex image x y 1227 1228 {-# INLINE unsafePixelAt #-} 1229 unsafePixelAt = V.unsafeIndex 1230 {-# INLINE unsafeReadPixel #-} 1231 unsafeReadPixel = M.unsafeRead 1232 {-# INLINE unsafeWritePixel #-} 1233 unsafeWritePixel = M.unsafeWrite 1234 1235instance ColorConvertible Pixel8 PixelYA8 where 1236 {-# INLINE promotePixel #-} 1237 promotePixel c = PixelYA8 c 255 1238 1239instance ColorConvertible Pixel8 PixelF where 1240 {-# INLINE promotePixel #-} 1241 promotePixel c = fromIntegral c / 255.0 1242 1243instance ColorConvertible Pixel8 Pixel16 where 1244 {-# INLINE promotePixel #-} 1245 promotePixel c = fromIntegral c * 257 1246 1247instance ColorConvertible Pixel8 PixelRGB8 where 1248 {-# INLINE promotePixel #-} 1249 promotePixel c = PixelRGB8 c c c 1250 1251instance ColorConvertible Pixel8 PixelRGB16 where 1252 {-# INLINE promotePixel #-} 1253 promotePixel c = PixelRGB16 (fromIntegral c * 257) (fromIntegral c * 257) (fromIntegral c * 257) 1254 1255instance ColorConvertible Pixel8 PixelRGBA8 where 1256 {-# INLINE promotePixel #-} 1257 promotePixel c = PixelRGBA8 c c c 255 1258 1259-------------------------------------------------- 1260---- Pixel16 instances 1261-------------------------------------------------- 1262instance Pixel Pixel16 where 1263 type PixelBaseComponent Pixel16 = Word16 1264 1265 {-# INLINE pixelOpacity #-} 1266 pixelOpacity = const maxBound 1267 1268 {-# INLINE mixWith #-} 1269 mixWith f = f 0 1270 1271 {-# INLINE colorMap #-} 1272 colorMap f = f 1273 1274 {-# INLINE componentCount #-} 1275 componentCount _ = 1 1276 {-# INLINE pixelAt #-} 1277 pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) 1278 1279 {-# INLINE readPixel #-} 1280 readPixel image@(MutableImage { mutableImageData = arr }) x y = 1281 arr `M.read` mutablePixelBaseIndex image x y 1282 1283 {-# INLINE writePixel #-} 1284 writePixel image@(MutableImage { mutableImageData = arr }) x y = 1285 arr `M.write` mutablePixelBaseIndex image x y 1286 1287 {-# INLINE unsafePixelAt #-} 1288 unsafePixelAt = V.unsafeIndex 1289 {-# INLINE unsafeReadPixel #-} 1290 unsafeReadPixel = M.unsafeRead 1291 {-# INLINE unsafeWritePixel #-} 1292 unsafeWritePixel = M.unsafeWrite 1293 1294instance ColorConvertible Pixel16 PixelYA16 where 1295 {-# INLINE promotePixel #-} 1296 promotePixel c = PixelYA16 c maxBound 1297 1298instance ColorConvertible Pixel16 PixelRGB16 where 1299 {-# INLINE promotePixel #-} 1300 promotePixel c = PixelRGB16 c c c 1301 1302instance ColorConvertible Pixel16 PixelRGBA16 where 1303 {-# INLINE promotePixel #-} 1304 promotePixel c = PixelRGBA16 c c c maxBound 1305 1306-------------------------------------------------- 1307---- Pixel32 instances 1308-------------------------------------------------- 1309instance Pixel Pixel32 where 1310 type PixelBaseComponent Pixel32 = Word32 1311 1312 {-# INLINE pixelOpacity #-} 1313 pixelOpacity = const maxBound 1314 1315 {-# INLINE mixWith #-} 1316 mixWith f = f 0 1317 1318 {-# INLINE colorMap #-} 1319 colorMap f = f 1320 1321 {-# INLINE componentCount #-} 1322 componentCount _ = 1 1323 1324 {-# INLINE pixelAt #-} 1325 pixelAt (Image { imageWidth = w, imageData = arr }) x y = arr ! (x + y * w) 1326 1327 {-# INLINE readPixel #-} 1328 readPixel image@(MutableImage { mutableImageData = arr }) x y = 1329 arr `M.read` mutablePixelBaseIndex image x y 1330 1331 {-# INLINE writePixel #-} 1332 writePixel image@(MutableImage { mutableImageData = arr }) x y = 1333 arr `M.write` mutablePixelBaseIndex image x y 1334 1335 {-# INLINE unsafePixelAt #-} 1336 unsafePixelAt = V.unsafeIndex 1337 {-# INLINE unsafeReadPixel #-} 1338 unsafeReadPixel = M.unsafeRead 1339 {-# INLINE unsafeWritePixel #-} 1340 unsafeWritePixel = M.unsafeWrite 1341 1342-------------------------------------------------- 1343---- PixelF instances 1344-------------------------------------------------- 1345instance Pixel PixelF where 1346 type PixelBaseComponent PixelF = Float 1347 1348 {-# INLINE pixelOpacity #-} 1349 pixelOpacity = const 1.0 1350 1351 {-# INLINE mixWith #-} 1352 mixWith f = f 0 1353 1354 {-# INLINE colorMap #-} 1355 colorMap f = f 1356 {-# INLINE componentCount #-} 1357 componentCount _ = 1 1358 {-# INLINE pixelAt #-} 1359 pixelAt (Image { imageWidth = w, imageData = arr }) x y = 1360 arr ! (x + y * w) 1361 1362 {-# INLINE readPixel #-} 1363 readPixel image@(MutableImage { mutableImageData = arr }) x y = 1364 arr `M.read` mutablePixelBaseIndex image x y 1365 1366 {-# INLINE writePixel #-} 1367 writePixel image@(MutableImage { mutableImageData = arr }) x y = 1368 arr `M.write` mutablePixelBaseIndex image x y 1369 1370 {-# INLINE unsafePixelAt #-} 1371 unsafePixelAt = V.unsafeIndex 1372 {-# INLINE unsafeReadPixel #-} 1373 unsafeReadPixel = M.unsafeRead 1374 {-# INLINE unsafeWritePixel #-} 1375 unsafeWritePixel = M.unsafeWrite 1376 1377instance ColorConvertible PixelF PixelRGBF where 1378 {-# INLINE promotePixel #-} 1379 promotePixel c = PixelRGBF c c c-- (c / 0.3) (c / 0.59) (c / 0.11) 1380 1381-------------------------------------------------- 1382---- PixelYA8 instances 1383-------------------------------------------------- 1384instance Pixel PixelYA8 where 1385 type PixelBaseComponent PixelYA8 = Word8 1386 1387 {-# INLINE pixelOpacity #-} 1388 pixelOpacity (PixelYA8 _ a) = a 1389 1390 {-# INLINE mixWith #-} 1391 mixWith f (PixelYA8 ya aa) (PixelYA8 yb ab) = 1392 PixelYA8 (f 0 ya yb) (f 1 aa ab) 1393 1394 1395 {-# INLINE colorMap #-} 1396 colorMap f (PixelYA8 y a) = PixelYA8 (f y) (f a) 1397 {-# INLINE componentCount #-} 1398 componentCount _ = 2 1399 {-# INLINE pixelAt #-} 1400 pixelAt image@(Image { imageData = arr }) x y = 1401 PixelYA8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) 1402 where baseIdx = pixelBaseIndex image x y 1403 1404 {-# INLINE readPixel #-} 1405 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1406 yv <- arr `M.read` baseIdx 1407 av <- arr `M.read` (baseIdx + 1) 1408 return $ PixelYA8 yv av 1409 where baseIdx = mutablePixelBaseIndex image x y 1410 1411 {-# INLINE writePixel #-} 1412 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA8 yv av) = do 1413 let baseIdx = mutablePixelBaseIndex image x y 1414 (arr `M.write` (baseIdx + 0)) yv 1415 (arr `M.write` (baseIdx + 1)) av 1416 1417 {-# INLINE unsafePixelAt #-} 1418 unsafePixelAt v idx = 1419 PixelYA8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) 1420 {-# INLINE unsafeReadPixel #-} 1421 unsafeReadPixel vec idx = 1422 PixelYA8 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) 1423 {-# INLINE unsafeWritePixel #-} 1424 unsafeWritePixel v idx (PixelYA8 y a) = 1425 M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a 1426 1427instance ColorConvertible PixelYA8 PixelRGB8 where 1428 {-# INLINE promotePixel #-} 1429 promotePixel (PixelYA8 y _) = PixelRGB8 y y y 1430 1431instance ColorConvertible PixelYA8 PixelRGB16 where 1432 {-# INLINE promotePixel #-} 1433 promotePixel (PixelYA8 y _) = PixelRGB16 (fromIntegral y * 257) (fromIntegral y * 257) (fromIntegral y * 257) 1434 1435instance ColorConvertible PixelYA8 PixelRGBA8 where 1436 {-# INLINE promotePixel #-} 1437 promotePixel (PixelYA8 y a) = PixelRGBA8 y y y a 1438 1439instance ColorPlane PixelYA8 PlaneLuma where 1440 toComponentIndex _ _ = 0 1441 1442instance ColorPlane PixelYA8 PlaneAlpha where 1443 toComponentIndex _ _ = 1 1444 1445instance TransparentPixel PixelYA8 Pixel8 where 1446 {-# INLINE dropTransparency #-} 1447 dropTransparency (PixelYA8 y _) = y 1448 {-# INLINE getTransparency #-} 1449 getTransparency (PixelYA8 _ a) = a 1450 1451instance LumaPlaneExtractable PixelYA8 where 1452 {-# INLINE computeLuma #-} 1453 computeLuma (PixelYA8 y _) = y 1454 extractLumaPlane = extractComponent PlaneLuma 1455 1456-------------------------------------------------- 1457---- PixelYA16 instances 1458-------------------------------------------------- 1459instance Pixel PixelYA16 where 1460 type PixelBaseComponent PixelYA16 = Word16 1461 1462 {-# INLINE pixelOpacity #-} 1463 pixelOpacity (PixelYA16 _ a) = a 1464 1465 {-# INLINE mixWith #-} 1466 mixWith f (PixelYA16 ya aa) (PixelYA16 yb ab) = 1467 PixelYA16 (f 0 ya yb) (f 1 aa ab) 1468 1469 {-# INLINE mixWithAlpha #-} 1470 mixWithAlpha f fa (PixelYA16 ya aa) (PixelYA16 yb ab) = 1471 PixelYA16 (f 0 ya yb) (fa aa ab) 1472 1473 {-# INLINE colorMap #-} 1474 colorMap f (PixelYA16 y a) = PixelYA16 (f y) (f a) 1475 {-# INLINE componentCount #-} 1476 componentCount _ = 2 1477 {-# INLINE pixelAt #-} 1478 pixelAt image@(Image { imageData = arr }) x y = PixelYA16 (arr ! (baseIdx + 0)) 1479 (arr ! (baseIdx + 1)) 1480 where baseIdx = pixelBaseIndex image x y 1481 1482 {-# INLINE readPixel #-} 1483 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1484 yv <- arr `M.read` baseIdx 1485 av <- arr `M.read` (baseIdx + 1) 1486 return $ PixelYA16 yv av 1487 where baseIdx = mutablePixelBaseIndex image x y 1488 1489 {-# INLINE writePixel #-} 1490 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYA16 yv av) = do 1491 let baseIdx = mutablePixelBaseIndex image x y 1492 (arr `M.write` (baseIdx + 0)) yv 1493 (arr `M.write` (baseIdx + 1)) av 1494 1495 {-# INLINE unsafePixelAt #-} 1496 unsafePixelAt v idx = 1497 PixelYA16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) 1498 {-# INLINE unsafeReadPixel #-} 1499 unsafeReadPixel vec idx = 1500 PixelYA16 `liftM` M.unsafeRead vec idx `ap` M.unsafeRead vec (idx + 1) 1501 {-# INLINE unsafeWritePixel #-} 1502 unsafeWritePixel v idx (PixelYA16 y a) = 1503 M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) a 1504 1505instance ColorConvertible PixelYA16 PixelRGB16 where 1506 {-# INLINE promotePixel #-} 1507 promotePixel (PixelYA16 y _) = PixelRGB16 y y y 1508 1509instance ColorConvertible PixelYA16 PixelRGBA16 where 1510 {-# INLINE promotePixel #-} 1511 promotePixel (PixelYA16 y a) = PixelRGBA16 y y y a 1512 1513instance ColorPlane PixelYA16 PlaneLuma where 1514 toComponentIndex _ _ = 0 1515 1516instance ColorPlane PixelYA16 PlaneAlpha where 1517 toComponentIndex _ _ = 1 1518 1519instance TransparentPixel PixelYA16 Pixel16 where 1520 {-# INLINE dropTransparency #-} 1521 dropTransparency (PixelYA16 y _) = y 1522 {-# INLINE getTransparency #-} 1523 getTransparency (PixelYA16 _ a) = a 1524 1525-------------------------------------------------- 1526---- PixelRGBF instances 1527-------------------------------------------------- 1528instance Pixel PixelRGBF where 1529 type PixelBaseComponent PixelRGBF = PixelF 1530 1531 {-# INLINE pixelOpacity #-} 1532 pixelOpacity = const 1.0 1533 1534 {-# INLINE mixWith #-} 1535 mixWith f (PixelRGBF ra ga ba) (PixelRGBF rb gb bb) = 1536 PixelRGBF (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) 1537 1538 {-# INLINE colorMap #-} 1539 colorMap f (PixelRGBF r g b) = PixelRGBF (f r) (f g) (f b) 1540 1541 {-# INLINE componentCount #-} 1542 componentCount _ = 3 1543 1544 {-# INLINE pixelAt #-} 1545 pixelAt image@(Image { imageData = arr }) x y = PixelRGBF (arr ! (baseIdx + 0)) 1546 (arr ! (baseIdx + 1)) 1547 (arr ! (baseIdx + 2)) 1548 where baseIdx = pixelBaseIndex image x y 1549 1550 {-# INLINE readPixel #-} 1551 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1552 rv <- arr `M.read` baseIdx 1553 gv <- arr `M.read` (baseIdx + 1) 1554 bv <- arr `M.read` (baseIdx + 2) 1555 return $ PixelRGBF rv gv bv 1556 where baseIdx = mutablePixelBaseIndex image x y 1557 1558 {-# INLINE writePixel #-} 1559 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBF rv gv bv) = do 1560 let baseIdx = mutablePixelBaseIndex image x y 1561 (arr `M.write` (baseIdx + 0)) rv 1562 (arr `M.write` (baseIdx + 1)) gv 1563 (arr `M.write` (baseIdx + 2)) bv 1564 1565 {-# INLINE unsafePixelAt #-} 1566 unsafePixelAt v idx = 1567 PixelRGBF (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) 1568 {-# INLINE unsafeReadPixel #-} 1569 unsafeReadPixel vec idx = 1570 PixelRGBF `liftM` M.unsafeRead vec idx 1571 `ap` M.unsafeRead vec (idx + 1) 1572 `ap` M.unsafeRead vec (idx + 2) 1573 {-# INLINE unsafeWritePixel #-} 1574 unsafeWritePixel v idx (PixelRGBF r g b) = 1575 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 1576 >> M.unsafeWrite v (idx + 2) b 1577 1578instance ColorPlane PixelRGBF PlaneRed where 1579 toComponentIndex _ _ = 0 1580 1581instance ColorPlane PixelRGBF PlaneGreen where 1582 toComponentIndex _ _ = 1 1583 1584instance ColorPlane PixelRGBF PlaneBlue where 1585 toComponentIndex _ _ = 2 1586 1587-------------------------------------------------- 1588---- PixelRGB16 instances 1589-------------------------------------------------- 1590instance Pixel PixelRGB16 where 1591 type PixelBaseComponent PixelRGB16 = Pixel16 1592 1593 {-# INLINE pixelOpacity #-} 1594 pixelOpacity = const maxBound 1595 1596 {-# INLINE mixWith #-} 1597 mixWith f (PixelRGB16 ra ga ba) (PixelRGB16 rb gb bb) = 1598 PixelRGB16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) 1599 1600 {-# INLINE colorMap #-} 1601 colorMap f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) 1602 1603 {-# INLINE componentCount #-} 1604 componentCount _ = 3 1605 1606 {-# INLINE pixelAt #-} 1607 pixelAt image@(Image { imageData = arr }) x y = PixelRGB16 (arr ! (baseIdx + 0)) 1608 (arr ! (baseIdx + 1)) 1609 (arr ! (baseIdx + 2)) 1610 where baseIdx = pixelBaseIndex image x y 1611 1612 {-# INLINE readPixel #-} 1613 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1614 rv <- arr `M.read` baseIdx 1615 gv <- arr `M.read` (baseIdx + 1) 1616 bv <- arr `M.read` (baseIdx + 2) 1617 return $ PixelRGB16 rv gv bv 1618 where baseIdx = mutablePixelBaseIndex image x y 1619 1620 {-# INLINE writePixel #-} 1621 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB16 rv gv bv) = do 1622 let baseIdx = mutablePixelBaseIndex image x y 1623 (arr `M.write` (baseIdx + 0)) rv 1624 (arr `M.write` (baseIdx + 1)) gv 1625 (arr `M.write` (baseIdx + 2)) bv 1626 1627 {-# INLINE unsafePixelAt #-} 1628 unsafePixelAt v idx = 1629 PixelRGB16 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) 1630 {-# INLINE unsafeReadPixel #-} 1631 unsafeReadPixel vec idx = 1632 PixelRGB16 `liftM` M.unsafeRead vec idx 1633 `ap` M.unsafeRead vec (idx + 1) 1634 `ap` M.unsafeRead vec (idx + 2) 1635 {-# INLINE unsafeWritePixel #-} 1636 unsafeWritePixel v idx (PixelRGB16 r g b) = 1637 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 1638 >> M.unsafeWrite v (idx + 2) b 1639 1640instance ColorPlane PixelRGB16 PlaneRed where 1641 toComponentIndex _ _ = 0 1642 1643instance ColorPlane PixelRGB16 PlaneGreen where 1644 toComponentIndex _ _ = 1 1645 1646instance ColorPlane PixelRGB16 PlaneBlue where 1647 toComponentIndex _ _ = 2 1648 1649instance ColorSpaceConvertible PixelRGB16 PixelCMYK16 where 1650 {-# INLINE convertPixel #-} 1651 convertPixel (PixelRGB16 r g b) = integralRGBToCMYK PixelCMYK16 (r, g, b) 1652 1653instance ColorConvertible PixelRGB16 PixelRGBA16 where 1654 {-# INLINE promotePixel #-} 1655 promotePixel (PixelRGB16 r g b) = PixelRGBA16 r g b maxBound 1656 1657instance LumaPlaneExtractable PixelRGB16 where 1658 {-# INLINE computeLuma #-} 1659 computeLuma (PixelRGB16 r g b) = 1660 floor $ (0.3 :: Double) * fromIntegral r 1661 + 0.59 * fromIntegral g 1662 + 0.11 * fromIntegral b 1663 1664-------------------------------------------------- 1665---- PixelRGB8 instances 1666-------------------------------------------------- 1667instance Pixel PixelRGB8 where 1668 type PixelBaseComponent PixelRGB8 = Word8 1669 1670 {-# INLINE pixelOpacity #-} 1671 pixelOpacity = const maxBound 1672 1673 {-# INLINE mixWith #-} 1674 mixWith f (PixelRGB8 ra ga ba) (PixelRGB8 rb gb bb) = 1675 PixelRGB8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) 1676 1677 {-# INLINE colorMap #-} 1678 colorMap f (PixelRGB8 r g b) = PixelRGB8 (f r) (f g) (f b) 1679 1680 {-# INLINE componentCount #-} 1681 componentCount _ = 3 1682 1683 {-# INLINE pixelAt #-} 1684 pixelAt image@(Image { imageData = arr }) x y = PixelRGB8 (arr ! (baseIdx + 0)) 1685 (arr ! (baseIdx + 1)) 1686 (arr ! (baseIdx + 2)) 1687 where baseIdx = pixelBaseIndex image x y 1688 1689 {-# INLINE readPixel #-} 1690 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1691 rv <- arr `M.read` baseIdx 1692 gv <- arr `M.read` (baseIdx + 1) 1693 bv <- arr `M.read` (baseIdx + 2) 1694 return $ PixelRGB8 rv gv bv 1695 where baseIdx = mutablePixelBaseIndex image x y 1696 1697 {-# INLINE writePixel #-} 1698 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGB8 rv gv bv) = do 1699 let baseIdx = mutablePixelBaseIndex image x y 1700 (arr `M.write` (baseIdx + 0)) rv 1701 (arr `M.write` (baseIdx + 1)) gv 1702 (arr `M.write` (baseIdx + 2)) bv 1703 1704 {-# INLINE unsafePixelAt #-} 1705 unsafePixelAt v idx = 1706 PixelRGB8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) 1707 {-# INLINE unsafeReadPixel #-} 1708 unsafeReadPixel vec idx = 1709 PixelRGB8 `liftM` M.unsafeRead vec idx 1710 `ap` M.unsafeRead vec (idx + 1) 1711 `ap` M.unsafeRead vec (idx + 2) 1712 {-# INLINE unsafeWritePixel #-} 1713 unsafeWritePixel v idx (PixelRGB8 r g b) = 1714 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 1715 >> M.unsafeWrite v (idx + 2) b 1716 1717instance ColorConvertible PixelRGB8 PixelRGBA8 where 1718 {-# INLINE promotePixel #-} 1719 promotePixel (PixelRGB8 r g b) = PixelRGBA8 r g b maxBound 1720 1721instance ColorConvertible PixelRGB8 PixelRGBF where 1722 {-# INLINE promotePixel #-} 1723 promotePixel (PixelRGB8 r g b) = PixelRGBF (toF r) (toF g) (toF b) 1724 where toF v = fromIntegral v / 255.0 1725 1726instance ColorConvertible PixelRGB8 PixelRGB16 where 1727 {-# INLINE promotePixel #-} 1728 promotePixel (PixelRGB8 r g b) = PixelRGB16 (promotePixel r) (promotePixel g) (promotePixel b) 1729 1730instance ColorConvertible PixelRGB8 PixelRGBA16 where 1731 {-# INLINE promotePixel #-} 1732 promotePixel (PixelRGB8 r g b) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) maxBound 1733 1734instance ColorPlane PixelRGB8 PlaneRed where 1735 toComponentIndex _ _ = 0 1736 1737instance ColorPlane PixelRGB8 PlaneGreen where 1738 toComponentIndex _ _ = 1 1739 1740instance ColorPlane PixelRGB8 PlaneBlue where 1741 toComponentIndex _ _ = 2 1742 1743instance LumaPlaneExtractable PixelRGB8 where 1744 {-# INLINE computeLuma #-} 1745 computeLuma (PixelRGB8 r g b) = 1746 floor $ (0.3 :: Double) * fromIntegral r 1747 + 0.59 * fromIntegral g 1748 + 0.11 * fromIntegral b 1749 1750-------------------------------------------------- 1751---- PixelRGBA8 instances 1752-------------------------------------------------- 1753instance Pixel PixelRGBA8 where 1754 type PixelBaseComponent PixelRGBA8 = Word8 1755 1756 {-# INLINE pixelOpacity #-} 1757 pixelOpacity (PixelRGBA8 _ _ _ a) = a 1758 1759 {-# INLINE mixWith #-} 1760 mixWith f (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = 1761 PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) 1762 1763 {-# INLINE mixWithAlpha #-} 1764 mixWithAlpha f fa (PixelRGBA8 ra ga ba aa) (PixelRGBA8 rb gb bb ab) = 1765 PixelRGBA8 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) 1766 1767 {-# INLINE colorMap #-} 1768 colorMap f (PixelRGBA8 r g b a) = PixelRGBA8 (f r) (f g) (f b) (f a) 1769 1770 {-# INLINE componentCount #-} 1771 componentCount _ = 4 1772 1773 {-# INLINE pixelAt #-} 1774 pixelAt image@(Image { imageData = arr }) x y = PixelRGBA8 (arr ! (baseIdx + 0)) 1775 (arr ! (baseIdx + 1)) 1776 (arr ! (baseIdx + 2)) 1777 (arr ! (baseIdx + 3)) 1778 where baseIdx = pixelBaseIndex image x y 1779 1780 {-# INLINE readPixel #-} 1781 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1782 rv <- arr `M.read` baseIdx 1783 gv <- arr `M.read` (baseIdx + 1) 1784 bv <- arr `M.read` (baseIdx + 2) 1785 av <- arr `M.read` (baseIdx + 3) 1786 return $ PixelRGBA8 rv gv bv av 1787 where baseIdx = mutablePixelBaseIndex image x y 1788 1789 {-# INLINE writePixel #-} 1790 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA8 rv gv bv av) = do 1791 let baseIdx = mutablePixelBaseIndex image x y 1792 (arr `M.write` (baseIdx + 0)) rv 1793 (arr `M.write` (baseIdx + 1)) gv 1794 (arr `M.write` (baseIdx + 2)) bv 1795 (arr `M.write` (baseIdx + 3)) av 1796 1797 {-# INLINE unsafePixelAt #-} 1798 unsafePixelAt v idx = 1799 PixelRGBA8 (V.unsafeIndex v idx) 1800 (V.unsafeIndex v $ idx + 1) 1801 (V.unsafeIndex v $ idx + 2) 1802 (V.unsafeIndex v $ idx + 3) 1803 1804 {-# INLINE unsafeReadPixel #-} 1805 unsafeReadPixel vec idx = 1806 PixelRGBA8 `liftM` M.unsafeRead vec idx 1807 `ap` M.unsafeRead vec (idx + 1) 1808 `ap` M.unsafeRead vec (idx + 2) 1809 `ap` M.unsafeRead vec (idx + 3) 1810 1811 {-# INLINE unsafeWritePixel #-} 1812 unsafeWritePixel v idx (PixelRGBA8 r g b a) = 1813 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 1814 >> M.unsafeWrite v (idx + 2) b 1815 >> M.unsafeWrite v (idx + 3) a 1816 1817instance ColorConvertible PixelRGBA8 PixelRGBA16 where 1818 {-# INLINE promotePixel #-} 1819 promotePixel (PixelRGBA8 r g b a) = PixelRGBA16 (promotePixel r) (promotePixel g) (promotePixel b) (promotePixel a) 1820 1821instance ColorPlane PixelRGBA8 PlaneRed where 1822 toComponentIndex _ _ = 0 1823 1824instance ColorPlane PixelRGBA8 PlaneGreen where 1825 toComponentIndex _ _ = 1 1826 1827instance ColorPlane PixelRGBA8 PlaneBlue where 1828 toComponentIndex _ _ = 2 1829 1830instance ColorPlane PixelRGBA8 PlaneAlpha where 1831 toComponentIndex _ _ = 3 1832 1833-------------------------------------------------- 1834---- PixelRGBA16 instances 1835-------------------------------------------------- 1836instance Pixel PixelRGBA16 where 1837 type PixelBaseComponent PixelRGBA16 = Pixel16 1838 1839 {-# INLINE pixelOpacity #-} 1840 pixelOpacity (PixelRGBA16 _ _ _ a) = a 1841 1842 {-# INLINE mixWith #-} 1843 mixWith f (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = 1844 PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (f 3 aa ab) 1845 1846 {-# INLINE mixWithAlpha #-} 1847 mixWithAlpha f fa (PixelRGBA16 ra ga ba aa) (PixelRGBA16 rb gb bb ab) = 1848 PixelRGBA16 (f 0 ra rb) (f 1 ga gb) (f 2 ba bb) (fa aa ab) 1849 1850 {-# INLINE colorMap #-} 1851 colorMap f (PixelRGBA16 r g b a) = PixelRGBA16 (f r) (f g) (f b) (f a) 1852 1853 {-# INLINE componentCount #-} 1854 componentCount _ = 4 1855 1856 {-# INLINE pixelAt #-} 1857 pixelAt image@(Image { imageData = arr }) x y = 1858 PixelRGBA16 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) 1859 (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) 1860 where baseIdx = pixelBaseIndex image x y 1861 1862 {-# INLINE readPixel #-} 1863 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1864 rv <- arr `M.read` baseIdx 1865 gv <- arr `M.read` (baseIdx + 1) 1866 bv <- arr `M.read` (baseIdx + 2) 1867 av <- arr `M.read` (baseIdx + 3) 1868 return $ PixelRGBA16 rv gv bv av 1869 where baseIdx = mutablePixelBaseIndex image x y 1870 1871 {-# INLINE writePixel #-} 1872 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelRGBA16 rv gv bv av) = do 1873 let baseIdx = mutablePixelBaseIndex image x y 1874 (arr `M.write` (baseIdx + 0)) rv 1875 (arr `M.write` (baseIdx + 1)) gv 1876 (arr `M.write` (baseIdx + 2)) bv 1877 (arr `M.write` (baseIdx + 3)) av 1878 1879 {-# INLINE unsafePixelAt #-} 1880 unsafePixelAt v idx = 1881 PixelRGBA16 (V.unsafeIndex v idx) 1882 (V.unsafeIndex v $ idx + 1) 1883 (V.unsafeIndex v $ idx + 2) 1884 (V.unsafeIndex v $ idx + 3) 1885 {-# INLINE unsafeReadPixel #-} 1886 unsafeReadPixel vec idx = 1887 PixelRGBA16 `liftM` M.unsafeRead vec idx 1888 `ap` M.unsafeRead vec (idx + 1) 1889 `ap` M.unsafeRead vec (idx + 2) 1890 `ap` M.unsafeRead vec (idx + 3) 1891 {-# INLINE unsafeWritePixel #-} 1892 unsafeWritePixel v idx (PixelRGBA16 r g b a) = 1893 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 1894 >> M.unsafeWrite v (idx + 2) b 1895 >> M.unsafeWrite v (idx + 3) a 1896 1897 1898instance TransparentPixel PixelRGBA16 PixelRGB16 where 1899 {-# INLINE dropTransparency #-} 1900 dropTransparency (PixelRGBA16 r g b _) = PixelRGB16 r g b 1901 {-# INLINE getTransparency #-} 1902 getTransparency (PixelRGBA16 _ _ _ a) = a 1903 1904instance ColorPlane PixelRGBA16 PlaneRed where 1905 toComponentIndex _ _ = 0 1906 1907instance ColorPlane PixelRGBA16 PlaneGreen where 1908 toComponentIndex _ _ = 1 1909 1910instance ColorPlane PixelRGBA16 PlaneBlue where 1911 toComponentIndex _ _ = 2 1912 1913instance ColorPlane PixelRGBA16 PlaneAlpha where 1914 toComponentIndex _ _ = 3 1915 1916-------------------------------------------------- 1917---- PixelYCbCr8 instances 1918-------------------------------------------------- 1919instance Pixel PixelYCbCr8 where 1920 type PixelBaseComponent PixelYCbCr8 = Word8 1921 1922 {-# INLINE pixelOpacity #-} 1923 pixelOpacity = const maxBound 1924 1925 {-# INLINE mixWith #-} 1926 mixWith f (PixelYCbCr8 ya cba cra) (PixelYCbCr8 yb cbb crb) = 1927 PixelYCbCr8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) 1928 1929 {-# INLINE colorMap #-} 1930 colorMap f (PixelYCbCr8 y cb cr) = PixelYCbCr8 (f y) (f cb) (f cr) 1931 {-# INLINE componentCount #-} 1932 componentCount _ = 3 1933 {-# INLINE pixelAt #-} 1934 pixelAt image@(Image { imageData = arr }) x y = PixelYCbCr8 (arr ! (baseIdx + 0)) 1935 (arr ! (baseIdx + 1)) 1936 (arr ! (baseIdx + 2)) 1937 where baseIdx = pixelBaseIndex image x y 1938 1939 {-# INLINE readPixel #-} 1940 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 1941 yv <- arr `M.read` baseIdx 1942 cbv <- arr `M.read` (baseIdx + 1) 1943 crv <- arr `M.read` (baseIdx + 2) 1944 return $ PixelYCbCr8 yv cbv crv 1945 where baseIdx = mutablePixelBaseIndex image x y 1946 1947 {-# INLINE writePixel #-} 1948 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCr8 yv cbv crv) = do 1949 let baseIdx = mutablePixelBaseIndex image x y 1950 (arr `M.write` (baseIdx + 0)) yv 1951 (arr `M.write` (baseIdx + 1)) cbv 1952 (arr `M.write` (baseIdx + 2)) crv 1953 1954 {-# INLINE unsafePixelAt #-} 1955 unsafePixelAt v idx = 1956 PixelYCbCr8 (V.unsafeIndex v idx) (V.unsafeIndex v $ idx + 1) (V.unsafeIndex v $ idx + 2) 1957 {-# INLINE unsafeReadPixel #-} 1958 unsafeReadPixel vec idx = 1959 PixelYCbCr8 `liftM` M.unsafeRead vec idx 1960 `ap` M.unsafeRead vec (idx + 1) 1961 `ap` M.unsafeRead vec (idx + 2) 1962 {-# INLINE unsafeWritePixel #-} 1963 unsafeWritePixel v idx (PixelYCbCr8 y cb cr) = 1964 M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb 1965 >> M.unsafeWrite v (idx + 2) cr 1966 1967instance (Pixel a) => ColorSpaceConvertible a a where 1968 convertPixel = id 1969 convertImage = id 1970 1971scaleBits, oneHalf :: Int 1972scaleBits = 16 1973oneHalf = 1 `unsafeShiftL` (scaleBits - 1) 1974 1975fix :: Float -> Int 1976fix x = floor $ x * fromIntegral ((1 :: Int) `unsafeShiftL` scaleBits) + 0.5 1977 1978 1979rYTab, gYTab, bYTab, rCbTab, gCbTab, bCbTab, gCrTab, bCrTab :: V.Vector Int 1980rYTab = V.fromListN 256 [fix 0.29900 * i | i <- [0..255] ] 1981gYTab = V.fromListN 256 [fix 0.58700 * i | i <- [0..255] ] 1982bYTab = V.fromListN 256 [fix 0.11400 * i + oneHalf | i <- [0..255] ] 1983rCbTab = V.fromListN 256 [(- fix 0.16874) * i | i <- [0..255] ] 1984gCbTab = V.fromListN 256 [(- fix 0.33126) * i | i <- [0..255] ] 1985bCbTab = V.fromListN 256 [fix 0.5 * i + (128 `unsafeShiftL` scaleBits) + oneHalf - 1| i <- [0..255] ] 1986gCrTab = V.fromListN 256 [(- fix 0.41869) * i | i <- [0..255] ] 1987bCrTab = V.fromListN 256 [(- fix 0.08131) * i | i <- [0..255] ] 1988 1989 1990instance ColorSpaceConvertible PixelRGB8 PixelYCbCr8 where 1991 {-# INLINE convertPixel #-} 1992 convertPixel (PixelRGB8 r g b) = PixelYCbCr8 (fromIntegral y) (fromIntegral cb) (fromIntegral cr) 1993 where ri = fromIntegral r 1994 gi = fromIntegral g 1995 bi = fromIntegral b 1996 1997 y = (rYTab `V.unsafeIndex` ri + gYTab `V.unsafeIndex` gi + bYTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits 1998 cb = (rCbTab `V.unsafeIndex` ri + gCbTab `V.unsafeIndex` gi + bCbTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits 1999 cr = (bCbTab `V.unsafeIndex` ri + gCrTab `V.unsafeIndex` gi + bCrTab `V.unsafeIndex` bi) `unsafeShiftR` scaleBits 2000 2001 convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData 2002 where maxi = w * h 2003 2004 rY = fix 0.29900 2005 gY = fix 0.58700 2006 bY = fix 0.11400 2007 rCb = - fix 0.16874 2008 gCb = - fix 0.33126 2009 bCb = fix 0.5 2010 gCr = - fix 0.41869 2011 bCr = - fix 0.08131 2012 2013 newData = runST $ do 2014 block <- M.new $ maxi * 3 2015 let traductor _ idx | idx >= maxi = return block 2016 traductor readIdx idx = do 2017 let ri = fromIntegral $ d `V.unsafeIndex` readIdx 2018 gi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) 2019 bi = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) 2020 2021 y = (rY * ri + gY * gi + bY * bi + oneHalf) `unsafeShiftR` scaleBits 2022 cb = (rCb * ri + gCb * gi + bCb * bi + (128 `unsafeShiftL` scaleBits) + oneHalf - 1) `unsafeShiftR` scaleBits 2023 cr = (bCb * ri + (128 `unsafeShiftL` scaleBits) + oneHalf - 1+ gCr * gi + bCr * bi) `unsafeShiftR` scaleBits 2024 2025 (block `M.unsafeWrite` (readIdx + 0)) $ fromIntegral y 2026 (block `M.unsafeWrite` (readIdx + 1)) $ fromIntegral cb 2027 (block `M.unsafeWrite` (readIdx + 2)) $ fromIntegral cr 2028 traductor (readIdx + 3) (idx + 1) 2029 2030 traductor 0 0 >>= V.freeze 2031 2032crRTab, cbBTab, crGTab, cbGTab :: V.Vector Int 2033crRTab = V.fromListN 256 [(fix 1.40200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] 2034cbBTab = V.fromListN 256 [(fix 1.77200 * x + oneHalf) `unsafeShiftR` scaleBits | x <- [-128 .. 127]] 2035crGTab = V.fromListN 256 [negate (fix 0.71414) * x | x <- [-128 .. 127]] 2036cbGTab = V.fromListN 256 [negate (fix 0.34414) * x + oneHalf | x <- [-128 .. 127]] 2037 2038instance ColorSpaceConvertible PixelYCbCr8 PixelRGB8 where 2039 {-# INLINE convertPixel #-} 2040 convertPixel (PixelYCbCr8 y cb cr) = PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) 2041 where clampWord8 = fromIntegral . max 0 . min 255 2042 yi = fromIntegral y 2043 cbi = fromIntegral cb 2044 cri = fromIntegral cr 2045 2046 r = yi + crRTab `V.unsafeIndex` cri 2047 g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits 2048 b = yi + cbBTab `V.unsafeIndex` cbi 2049 2050 convertImage Image { imageWidth = w, imageHeight = h, imageData = d } = Image w h newData 2051 where maxi = w * h 2052 clampWord8 v | v < 0 = 0 2053 | v > 255 = 255 2054 | otherwise = fromIntegral v 2055 2056 newData = runST $ do 2057 block <- M.new $ maxi * 3 2058 let traductor _ idx | idx >= maxi = return block 2059 traductor readIdx idx = do 2060 let yi = fromIntegral $ d `V.unsafeIndex` readIdx 2061 cbi = fromIntegral $ d `V.unsafeIndex` (readIdx + 1) 2062 cri = fromIntegral $ d `V.unsafeIndex` (readIdx + 2) 2063 2064 r = yi + crRTab `V.unsafeIndex` cri 2065 g = yi + (cbGTab `V.unsafeIndex` cbi + crGTab `V.unsafeIndex` cri) `unsafeShiftR` scaleBits 2066 b = yi + cbBTab `V.unsafeIndex` cbi 2067 2068 (block `M.unsafeWrite` (readIdx + 0)) $ clampWord8 r 2069 (block `M.unsafeWrite` (readIdx + 1)) $ clampWord8 g 2070 (block `M.unsafeWrite` (readIdx + 2)) $ clampWord8 b 2071 traductor (readIdx + 3) (idx + 1) 2072 2073 traductor 0 0 >>= V.freeze 2074 2075instance ColorPlane PixelYCbCr8 PlaneLuma where 2076 toComponentIndex _ _ = 0 2077 2078instance ColorPlane PixelYCbCr8 PlaneCb where 2079 toComponentIndex _ _ = 1 2080 2081instance ColorPlane PixelYCbCr8 PlaneCr where 2082 toComponentIndex _ _ = 2 2083 2084-------------------------------------------------- 2085---- PixelCMYK8 instances 2086-------------------------------------------------- 2087instance Pixel PixelCMYK8 where 2088 type PixelBaseComponent PixelCMYK8 = Word8 2089 2090 {-# INLINE pixelOpacity #-} 2091 pixelOpacity = const maxBound 2092 2093 {-# INLINE mixWith #-} 2094 mixWith f (PixelCMYK8 ca ma ya ka) (PixelCMYK8 cb mb yb kb) = 2095 PixelCMYK8 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) 2096 2097 {-# INLINE colorMap #-} 2098 colorMap f (PixelCMYK8 c m y k) = PixelCMYK8 (f c) (f m) (f y) (f k) 2099 2100 {-# INLINE componentCount #-} 2101 componentCount _ = 4 2102 2103 {-# INLINE pixelAt #-} 2104 pixelAt image@(Image { imageData = arr }) x y = PixelCMYK8 (arr ! (baseIdx + 0)) 2105 (arr ! (baseIdx + 1)) 2106 (arr ! (baseIdx + 2)) 2107 (arr ! (baseIdx + 3)) 2108 where baseIdx = pixelBaseIndex image x y 2109 2110 {-# INLINE readPixel #-} 2111 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 2112 rv <- arr `M.read` baseIdx 2113 gv <- arr `M.read` (baseIdx + 1) 2114 bv <- arr `M.read` (baseIdx + 2) 2115 av <- arr `M.read` (baseIdx + 3) 2116 return $ PixelCMYK8 rv gv bv av 2117 where baseIdx = mutablePixelBaseIndex image x y 2118 2119 {-# INLINE writePixel #-} 2120 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK8 rv gv bv av) = do 2121 let baseIdx = mutablePixelBaseIndex image x y 2122 (arr `M.write` (baseIdx + 0)) rv 2123 (arr `M.write` (baseIdx + 1)) gv 2124 (arr `M.write` (baseIdx + 2)) bv 2125 (arr `M.write` (baseIdx + 3)) av 2126 2127 {-# INLINE unsafePixelAt #-} 2128 unsafePixelAt v idx = 2129 PixelCMYK8 (V.unsafeIndex v idx) 2130 (V.unsafeIndex v $ idx + 1) 2131 (V.unsafeIndex v $ idx + 2) 2132 (V.unsafeIndex v $ idx + 3) 2133 2134 {-# INLINE unsafeReadPixel #-} 2135 unsafeReadPixel vec idx = 2136 PixelCMYK8 `liftM` M.unsafeRead vec idx 2137 `ap` M.unsafeRead vec (idx + 1) 2138 `ap` M.unsafeRead vec (idx + 2) 2139 `ap` M.unsafeRead vec (idx + 3) 2140 2141 {-# INLINE unsafeWritePixel #-} 2142 unsafeWritePixel v idx (PixelCMYK8 r g b a) = 2143 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 2144 >> M.unsafeWrite v (idx + 2) b 2145 >> M.unsafeWrite v (idx + 3) a 2146 2147instance ColorSpaceConvertible PixelCMYK8 PixelRGB8 where 2148 convertPixel (PixelCMYK8 c m y k) = 2149 PixelRGB8 (clampWord8 r) (clampWord8 g) (clampWord8 b) 2150 where 2151 clampWord8 = fromIntegral . max 0 . min 255 . (`div` 255) 2152 ik :: Int 2153 ik = 255 - fromIntegral k 2154 2155 r = (255 - fromIntegral c) * ik 2156 g = (255 - fromIntegral m) * ik 2157 b = (255 - fromIntegral y) * ik 2158 2159-------------------------------------------------- 2160---- PixelYCbCrK8 instances 2161-------------------------------------------------- 2162instance Pixel PixelYCbCrK8 where 2163 type PixelBaseComponent PixelYCbCrK8 = Word8 2164 2165 {-# INLINE pixelOpacity #-} 2166 pixelOpacity = const maxBound 2167 2168 {-# INLINE mixWith #-} 2169 mixWith f (PixelYCbCrK8 ya cba cra ka) (PixelYCbCrK8 yb cbb crb kb) = 2170 PixelYCbCrK8 (f 0 ya yb) (f 1 cba cbb) (f 2 cra crb) (f 3 ka kb) 2171 2172 {-# INLINE colorMap #-} 2173 colorMap f (PixelYCbCrK8 y cb cr k) = PixelYCbCrK8 (f y) (f cb) (f cr) (f k) 2174 2175 {-# INLINE componentCount #-} 2176 componentCount _ = 4 2177 2178 {-# INLINE pixelAt #-} 2179 pixelAt image@(Image { imageData = arr }) x y = 2180 PixelYCbCrK8 (arr ! (baseIdx + 0)) (arr ! (baseIdx + 1)) 2181 (arr ! (baseIdx + 2)) (arr ! (baseIdx + 3)) 2182 where baseIdx = pixelBaseIndex image x y 2183 2184 {-# INLINE readPixel #-} 2185 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 2186 yv <- arr `M.read` baseIdx 2187 cbv <- arr `M.read` (baseIdx + 1) 2188 crv <- arr `M.read` (baseIdx + 2) 2189 kv <- arr `M.read` (baseIdx + 3) 2190 return $ PixelYCbCrK8 yv cbv crv kv 2191 where baseIdx = mutablePixelBaseIndex image x y 2192 2193 {-# INLINE writePixel #-} 2194 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelYCbCrK8 yv cbv crv kv) = do 2195 let baseIdx = mutablePixelBaseIndex image x y 2196 (arr `M.write` (baseIdx + 0)) yv 2197 (arr `M.write` (baseIdx + 1)) cbv 2198 (arr `M.write` (baseIdx + 2)) crv 2199 (arr `M.write` (baseIdx + 3)) kv 2200 2201 {-# INLINE unsafePixelAt #-} 2202 unsafePixelAt v idx = 2203 PixelYCbCrK8 (V.unsafeIndex v idx) 2204 (V.unsafeIndex v $ idx + 1) 2205 (V.unsafeIndex v $ idx + 2) 2206 (V.unsafeIndex v $ idx + 3) 2207 2208 {-# INLINE unsafeReadPixel #-} 2209 unsafeReadPixel vec idx = 2210 PixelYCbCrK8 `liftM` M.unsafeRead vec idx 2211 `ap` M.unsafeRead vec (idx + 1) 2212 `ap` M.unsafeRead vec (idx + 2) 2213 `ap` M.unsafeRead vec (idx + 3) 2214 2215 {-# INLINE unsafeWritePixel #-} 2216 unsafeWritePixel v idx (PixelYCbCrK8 y cb cr k) = 2217 M.unsafeWrite v idx y >> M.unsafeWrite v (idx + 1) cb 2218 >> M.unsafeWrite v (idx + 2) cr 2219 >> M.unsafeWrite v (idx + 3) k 2220 2221instance ColorSpaceConvertible PixelYCbCrK8 PixelRGB8 where 2222 convertPixel (PixelYCbCrK8 y cb cr _k) = PixelRGB8 (clamp r) (clamp g) (clamp b) 2223 where 2224 tof :: Word8 -> Float 2225 tof = fromIntegral 2226 2227 clamp :: Float -> Word8 2228 clamp = floor . max 0 . min 255 2229 2230 yf = tof y 2231 2232 r = yf + 1.402 * tof cr - 179.456 2233 g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 2234 b = yf + 1.772 * tof cb - 226.816 2235 2236instance ColorSpaceConvertible PixelYCbCrK8 PixelCMYK8 where 2237 convertPixel (PixelYCbCrK8 y cb cr k) = PixelCMYK8 c m ye k 2238 where 2239 tof :: Word8 -> Float 2240 tof = fromIntegral 2241 2242 clamp :: Float -> Word8 2243 clamp = floor . max 0 . min 255 2244 2245 yf = tof y 2246 2247 r = yf + 1.402 * tof cr - 179.456 2248 g = yf - 0.3441363 * tof cb - 0.71413636 * tof cr + 135.4589 2249 b = yf + 1.772 * tof cb - 226.816 2250 2251 c = clamp $ 255 - r 2252 m = clamp $ 255 - g 2253 ye = clamp $ 255 - b 2254 2255{-# SPECIALIZE integralRGBToCMYK :: (Word8 -> Word8 -> Word8 -> Word8 -> b) 2256 -> (Word8, Word8, Word8) -> b #-} 2257{-# SPECIALIZE integralRGBToCMYK :: (Word16 -> Word16 -> Word16 -> Word16 -> b) 2258 -> (Word16, Word16, Word16) -> b #-} 2259-- | Convert RGB8 or RGB16 to CMYK8 and CMYK16 respectfully. 2260-- 2261-- /Note/ - 32bit precision is not supported. Make sure to adjust implementation if ever 2262-- used with Word32. 2263integralRGBToCMYK :: (Bounded a, Integral a) 2264 => (a -> a -> a -> a -> b) -- ^ Pixel building function 2265 -> (a, a, a) -- ^ RGB sample 2266 -> b -- ^ Resulting sample 2267integralRGBToCMYK build (r, g, b) 2268 | kMax == 0 = build 0 0 0 maxVal -- prevent division by zero 2269 | otherwise = build (fromIntegral c) (fromIntegral m) (fromIntegral y) k 2270 where maxVal = maxBound 2271 max32 = fromIntegral maxVal :: Word32 2272 kMax32 = fromIntegral kMax :: Word32 2273 kMax = max r (max g b) 2274 k = maxVal - kMax 2275 c = max32 * (kMax32 - fromIntegral r) `div` kMax32 2276 m = max32 * (kMax32 - fromIntegral g) `div` kMax32 2277 y = max32 * (kMax32 - fromIntegral b) `div` kMax32 2278 2279instance ColorSpaceConvertible PixelRGB8 PixelCMYK8 where 2280 convertPixel (PixelRGB8 r g b) = integralRGBToCMYK PixelCMYK8 (r, g, b) 2281 2282instance ColorPlane PixelCMYK8 PlaneCyan where 2283 toComponentIndex _ _ = 0 2284 2285instance ColorPlane PixelCMYK8 PlaneMagenta where 2286 toComponentIndex _ _ = 1 2287 2288instance ColorPlane PixelCMYK8 PlaneYellow where 2289 toComponentIndex _ _ = 2 2290 2291instance ColorPlane PixelCMYK8 PlaneBlack where 2292 toComponentIndex _ _ = 3 2293 2294-------------------------------------------------- 2295---- PixelCMYK16 instances 2296-------------------------------------------------- 2297instance Pixel PixelCMYK16 where 2298 type PixelBaseComponent PixelCMYK16 = Word16 2299 2300 {-# INLINE pixelOpacity #-} 2301 pixelOpacity = const maxBound 2302 2303 {-# INLINE mixWith #-} 2304 mixWith f (PixelCMYK16 ca ma ya ka) (PixelCMYK16 cb mb yb kb) = 2305 PixelCMYK16 (f 0 ca cb) (f 1 ma mb) (f 2 ya yb) (f 3 ka kb) 2306 2307 {-# INLINE colorMap #-} 2308 colorMap f (PixelCMYK16 c m y k) = PixelCMYK16 (f c) (f m) (f y) (f k) 2309 2310 {-# INLINE componentCount #-} 2311 componentCount _ = 4 2312 2313 {-# INLINE pixelAt #-} 2314 pixelAt image@(Image { imageData = arr }) x y = PixelCMYK16 (arr ! (baseIdx + 0)) 2315 (arr ! (baseIdx + 1)) 2316 (arr ! (baseIdx + 2)) 2317 (arr ! (baseIdx + 3)) 2318 where baseIdx = pixelBaseIndex image x y 2319 2320 {-# INLINE readPixel #-} 2321 readPixel image@(MutableImage { mutableImageData = arr }) x y = do 2322 rv <- arr `M.read` baseIdx 2323 gv <- arr `M.read` (baseIdx + 1) 2324 bv <- arr `M.read` (baseIdx + 2) 2325 av <- arr `M.read` (baseIdx + 3) 2326 return $ PixelCMYK16 rv gv bv av 2327 where baseIdx = mutablePixelBaseIndex image x y 2328 2329 {-# INLINE writePixel #-} 2330 writePixel image@(MutableImage { mutableImageData = arr }) x y (PixelCMYK16 rv gv bv av) = do 2331 let baseIdx = mutablePixelBaseIndex image x y 2332 (arr `M.write` (baseIdx + 0)) rv 2333 (arr `M.write` (baseIdx + 1)) gv 2334 (arr `M.write` (baseIdx + 2)) bv 2335 (arr `M.write` (baseIdx + 3)) av 2336 2337 {-# INLINE unsafePixelAt #-} 2338 unsafePixelAt v idx = 2339 PixelCMYK16 (V.unsafeIndex v idx) 2340 (V.unsafeIndex v $ idx + 1) 2341 (V.unsafeIndex v $ idx + 2) 2342 (V.unsafeIndex v $ idx + 3) 2343 2344 {-# INLINE unsafeReadPixel #-} 2345 unsafeReadPixel vec idx = 2346 PixelCMYK16 `liftM` M.unsafeRead vec idx 2347 `ap` M.unsafeRead vec (idx + 1) 2348 `ap` M.unsafeRead vec (idx + 2) 2349 `ap` M.unsafeRead vec (idx + 3) 2350 {-# INLINE unsafeWritePixel #-} 2351 unsafeWritePixel v idx (PixelCMYK16 r g b a) = 2352 M.unsafeWrite v idx r >> M.unsafeWrite v (idx + 1) g 2353 >> M.unsafeWrite v (idx + 2) b 2354 >> M.unsafeWrite v (idx + 3) a 2355 2356instance ColorSpaceConvertible PixelCMYK16 PixelRGB16 where 2357 convertPixel (PixelCMYK16 c m y k) = 2358 PixelRGB16 (clampWord16 r) (clampWord16 g) (clampWord16 b) 2359 where 2360 clampWord16 = fromIntegral . (`unsafeShiftR` 16) 2361 ik :: Int 2362 ik = 65535 - fromIntegral k 2363 2364 r = (65535 - fromIntegral c) * ik 2365 g = (65535 - fromIntegral m) * ik 2366 b = (65535 - fromIntegral y) * ik 2367 2368instance ColorPlane PixelCMYK16 PlaneCyan where 2369 toComponentIndex _ _ = 0 2370 2371instance ColorPlane PixelCMYK16 PlaneMagenta where 2372 toComponentIndex _ _ = 1 2373 2374instance ColorPlane PixelCMYK16 PlaneYellow where 2375 toComponentIndex _ _ = 2 2376 2377instance ColorPlane PixelCMYK16 PlaneBlack where 2378 toComponentIndex _ _ = 3 2379 2380-- | Perform a gamma correction for an image with HDR pixels. 2381gammaCorrection :: PixelF -- ^ Gamma value, should be between 0.5 and 3.0 2382 -> Image PixelRGBF -- ^ Image to treat. 2383 -> Image PixelRGBF 2384gammaCorrection gammaVal = pixelMap gammaCorrector 2385 where gammaExponent = 1.0 / gammaVal 2386 fixVal v = v ** gammaExponent 2387 gammaCorrector (PixelRGBF r g b) = 2388 PixelRGBF (fixVal r) (fixVal g) (fixVal b) 2389 2390-- | Perform a tone mapping operation on an High dynamic range image. 2391toneMapping :: PixelF -- ^ Exposure parameter 2392 -> Image PixelRGBF -- ^ Image to treat. 2393 -> Image PixelRGBF 2394toneMapping exposure img = Image (imageWidth img) (imageHeight img) scaledData 2395 where coeff = exposure * (exposure / maxBrightness + 1.0) / (exposure + 1.0); 2396 maxBrightness = pixelFold (\luma _ _ px -> max luma $ computeLuma px) 0 img 2397 scaledData = V.map (* coeff) $ imageData img 2398 2399-------------------------------------------------- 2400---- Packable pixel 2401-------------------------------------------------- 2402 2403-- | This typeclass exist for performance reason, it allow 2404-- to pack a pixel value to a simpler "primitive" data 2405-- type to allow faster writing to moemory. 2406class PackeablePixel a where 2407 -- | Primitive type asociated to the current pixel 2408 -- It's Word32 for PixelRGBA8 for instance 2409 type PackedRepresentation a 2410 2411 -- | The packing function, allowing to transform 2412 -- to a primitive. 2413 packPixel :: a -> PackedRepresentation a 2414 2415 -- | Inverse transformation, to speed up 2416 -- reading 2417 unpackPixel :: PackedRepresentation a -> a 2418 2419instance PackeablePixel Pixel8 where 2420 type PackedRepresentation Pixel8 = Pixel8 2421 packPixel = id 2422 {-# INLINE packPixel #-} 2423 unpackPixel = id 2424 {-# INLINE unpackPixel #-} 2425 2426instance PackeablePixel Pixel16 where 2427 type PackedRepresentation Pixel16 = Pixel16 2428 packPixel = id 2429 {-# INLINE packPixel #-} 2430 unpackPixel = id 2431 {-# INLINE unpackPixel #-} 2432 2433instance PackeablePixel Pixel32 where 2434 type PackedRepresentation Pixel32 = Pixel32 2435 packPixel = id 2436 {-# INLINE packPixel #-} 2437 unpackPixel = id 2438 {-# INLINE unpackPixel #-} 2439 2440instance PackeablePixel PixelF where 2441 type PackedRepresentation PixelF = PixelF 2442 packPixel = id 2443 {-# INLINE packPixel #-} 2444 unpackPixel = id 2445 {-# INLINE unpackPixel #-} 2446 2447 2448instance PackeablePixel PixelRGBA8 where 2449 type PackedRepresentation PixelRGBA8 = Word32 2450 {-# INLINE packPixel #-} 2451 packPixel (PixelRGBA8 r g b a) = 2452 (fi r `unsafeShiftL` (0 * bitCount)) .|. 2453 (fi g `unsafeShiftL` (1 * bitCount)) .|. 2454 (fi b `unsafeShiftL` (2 * bitCount)) .|. 2455 (fi a `unsafeShiftL` (3 * bitCount)) 2456 where fi = fromIntegral 2457 bitCount = 8 2458 2459 {-# INLINE unpackPixel #-} 2460 unpackPixel w = 2461 PixelRGBA8 (low w) 2462 (low $ w `unsafeShiftR` bitCount) 2463 (low $ w `unsafeShiftR` (2 * bitCount)) 2464 (low $ w `unsafeShiftR` (3 * bitCount)) 2465 where 2466 low v = fromIntegral (v .&. 0xFF) 2467 bitCount = 8 2468 2469instance PackeablePixel PixelRGBA16 where 2470 type PackedRepresentation PixelRGBA16 = Word64 2471 {-# INLINE packPixel #-} 2472 packPixel (PixelRGBA16 r g b a) = 2473 (fi r `unsafeShiftL` (0 * bitCount)) .|. 2474 (fi g `unsafeShiftL` (1 * bitCount)) .|. 2475 (fi b `unsafeShiftL` (2 * bitCount)) .|. 2476 (fi a `unsafeShiftL` (3 * bitCount)) 2477 where fi = fromIntegral 2478 bitCount = 16 2479 2480 {-# INLINE unpackPixel #-} 2481 unpackPixel w = 2482 PixelRGBA16 (low w) 2483 (low $ w `unsafeShiftR` bitCount) 2484 (low $ w `unsafeShiftR` (2 * bitCount)) 2485 (low $ w `unsafeShiftR` (3 * bitCount)) 2486 where 2487 low v = fromIntegral (v .&. 0xFFFF) 2488 bitCount = 16 2489 2490instance PackeablePixel PixelCMYK8 where 2491 type PackedRepresentation PixelCMYK8 = Word32 2492 {-# INLINE packPixel #-} 2493 packPixel (PixelCMYK8 c m y k) = 2494 (fi c `unsafeShiftL` (0 * bitCount)) .|. 2495 (fi m `unsafeShiftL` (1 * bitCount)) .|. 2496 (fi y `unsafeShiftL` (2 * bitCount)) .|. 2497 (fi k `unsafeShiftL` (3 * bitCount)) 2498 where fi = fromIntegral 2499 bitCount = 8 2500 2501 {-# INLINE unpackPixel #-} 2502 unpackPixel w = 2503 PixelCMYK8 (low w) 2504 (low $ w `unsafeShiftR` bitCount) 2505 (low $ w `unsafeShiftR` (2 * bitCount)) 2506 (low $ w `unsafeShiftR` (3 * bitCount)) 2507 where 2508 low v = fromIntegral (v .&. 0xFF) 2509 bitCount = 8 2510 2511instance PackeablePixel PixelCMYK16 where 2512 type PackedRepresentation PixelCMYK16 = Word64 2513 {-# INLINE packPixel #-} 2514 packPixel (PixelCMYK16 c m y k) = 2515 (fi c `unsafeShiftL` (0 * bitCount)) .|. 2516 (fi m `unsafeShiftL` (1 * bitCount)) .|. 2517 (fi y `unsafeShiftL` (2 * bitCount)) .|. 2518 (fi k `unsafeShiftL` (3 * bitCount)) 2519 where fi = fromIntegral 2520 bitCount = 16 2521 2522 {-# INLINE unpackPixel #-} 2523 unpackPixel w = 2524 PixelCMYK16 (low w) 2525 (low $ w `unsafeShiftR` bitCount) 2526 (low $ w `unsafeShiftR` (2 * bitCount)) 2527 (low $ w `unsafeShiftR` (3 * bitCount)) 2528 where 2529 low v = fromIntegral (v .&. 0xFFFF) 2530 bitCount = 16 2531 2532instance PackeablePixel PixelYA16 where 2533 type PackedRepresentation PixelYA16 = Word32 2534 {-# INLINE packPixel #-} 2535 packPixel (PixelYA16 y a) = 2536 (fi y `unsafeShiftL` (0 * bitCount)) .|. 2537 (fi a `unsafeShiftL` (1 * bitCount)) 2538 where fi = fromIntegral 2539 bitCount = 16 2540 2541 {-# INLINE unpackPixel #-} 2542 unpackPixel w = PixelYA16 (low w) (low $ w `unsafeShiftR` bitCount) 2543 where 2544 low v = fromIntegral (v .&. 0xFFFF) 2545 bitCount = 16 2546 2547instance PackeablePixel PixelYA8 where 2548 type PackedRepresentation PixelYA8 = Word16 2549 {-# INLINE packPixel #-} 2550 packPixel (PixelYA8 y a) = 2551 (fi y `unsafeShiftL` (0 * bitCount)) .|. 2552 (fi a `unsafeShiftL` (1 * bitCount)) 2553 where fi = fromIntegral 2554 bitCount = 8 2555 2556 {-# INLINE unpackPixel #-} 2557 unpackPixel w = PixelYA8 (low w) (low $ w `unsafeShiftR` bitCount) 2558 where 2559 low v = fromIntegral (v .&. 0xFF) 2560 bitCount = 8 2561 2562-- | This function will fill an image with a simple packeable 2563-- pixel. It will be faster than any unsafeWritePixel. 2564fillImageWith :: ( Pixel px, PackeablePixel px 2565 , PrimMonad m 2566 , M.Storable (PackedRepresentation px)) 2567 => MutableImage (PrimState m) px -> px -> m () 2568fillImageWith img px = M.set converted $ packPixel px 2569 where 2570 (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img 2571 !packedPtr = castForeignPtr ptr 2572 !converted = 2573 M.unsafeFromForeignPtr packedPtr s (s2 `div` componentCount px) 2574 2575-- | Fill a packeable pixel between two bounds. 2576unsafeWritePixelBetweenAt 2577 :: ( PrimMonad m 2578 , Pixel px, PackeablePixel px 2579 , M.Storable (PackedRepresentation px)) 2580 => MutableImage (PrimState m) px -- ^ Image to write into 2581 -> px -- ^ Pixel to write 2582 -> Int -- ^ Start index in pixel base component 2583 -> Int -- ^ pixel count of pixel to write 2584 -> m () 2585unsafeWritePixelBetweenAt img px start count = M.set converted packed 2586 where 2587 !packed = packPixel px 2588 !pixelData = mutableImageData img 2589 2590 !toSet = M.slice start count pixelData 2591 (ptr, s, s2) = M.unsafeToForeignPtr toSet 2592 !packedPtr = castForeignPtr ptr 2593 !converted = 2594 M.unsafeFromForeignPtr packedPtr s s2 2595 2596-- | Read a packeable pixel from an image. Equivalent to 2597-- unsafeReadPixel 2598readPackedPixelAt :: forall m px. 2599 ( Pixel px, PackeablePixel px 2600 , M.Storable (PackedRepresentation px) 2601 , PrimMonad m 2602 ) 2603 => MutableImage (PrimState m) px -- ^ Image to read from 2604 -> Int -- ^ Index in (PixelBaseComponent px) count 2605 -> m px 2606{-# INLINE readPackedPixelAt #-} 2607readPackedPixelAt img idx = do 2608 unpacked <- M.unsafeRead converted (idx `div` compCount) 2609 return $ unpackPixel unpacked 2610 where 2611 !compCount = componentCount (undefined :: px) 2612 (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img 2613 !packedPtr = castForeignPtr ptr 2614 !converted = 2615 M.unsafeFromForeignPtr packedPtr s s2 2616 2617 2618-- | Write a packeable pixel into an image. equivalent to unsafeWritePixel. 2619writePackedPixelAt :: ( Pixel px, PackeablePixel px 2620 , M.Storable (PackedRepresentation px) 2621 , PrimMonad m 2622 ) 2623 => MutableImage (PrimState m) px -- ^ Image to write into 2624 -> Int -- ^ Index in (PixelBaseComponent px) count 2625 -> px -- ^ Pixel to write 2626 -> m () 2627{-# INLINE writePackedPixelAt #-} 2628writePackedPixelAt img idx px = 2629 M.unsafeWrite converted (idx `div` compCount) packed 2630 where 2631 !packed = packPixel px 2632 !compCount = componentCount px 2633 2634 (ptr, s, s2) = M.unsafeToForeignPtr $ mutableImageData img 2635 !packedPtr = castForeignPtr ptr 2636 !converted = 2637 M.unsafeFromForeignPtr packedPtr s s2 2638 2639{-# ANN module "HLint: ignore Reduce duplication" #-} 2640 2641