diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +1.5.2.0 +======= + +* Fixed `Storable` instance for some Pixel types. +* Fixed reading/writing animated GIFs. Added a detailed example to documentation. +* Improved encodeing/decoding of images. +* Improved coversion between `ColorSpace`s. + 1.5.1.0 ======= @@ -102,3 +110,5 @@ * Made it compatible with GHC >= 7.4 (#1) * Added histogram plotting using Charts + + diff --git a/benchmarks/Canny.hs b/benchmarks/Canny.hs --- a/benchmarks/Canny.hs +++ b/benchmarks/Canny.hs @@ -78,6 +78,7 @@ main = do -- img' <- readImageRGB RPU "images/frog.jpg" -- let !imgU = compute img' + let _foo = GIFALooping let !imgU = compute $ makeImage (1024, 768) (\(i, j) -> fromIntegral ((min i j) `div` (1 + max i j ))) :: Image RPU Y Word8 diff --git a/hip.cabal b/hip.cabal --- a/hip.cabal +++ b/hip.cabal @@ -1,5 +1,5 @@ Name: hip -Version: 1.5.1.0 +Version: 1.5.2.0 License: BSD3 License-File: LICENSE Author: Alexey Kuleshevich @@ -20,6 +20,8 @@ Build-Type: Simple Extra-Doc-Files: images/*.jpg , images/*.png + , images/*.gif + , images/downloaded/*.gif , images/*.svg , README.md CHANGELOG.md @@ -74,8 +76,11 @@ , Graphics.Image.ColorSpace.Y , Graphics.Image.ColorSpace.YCbCr , Graphics.Image.IO.Base - , Graphics.Image.IO.Formats.JuicyPixels + , Graphics.Image.IO.Formats.JuicyPixels.Common + , Graphics.Image.IO.Formats.JuicyPixels.Readable + , Graphics.Image.IO.Formats.JuicyPixels.Writable , Graphics.Image.IO.Formats.Netpbm + , Graphics.Image.Interface.Elevator , Graphics.Image.Interface.Repa.Generic , Graphics.Image.Interface.Repa.Storable , Graphics.Image.Interface.Repa.Unboxed @@ -118,7 +123,7 @@ GHC-Options: -Wall -threaded -with-rtsopts=-N -benchmark convolution-benchmarks +benchmark convolution type: exitcode-stdio-1.0 hs-source-dirs: benchmarks main-is: Canny.hs @@ -131,6 +136,7 @@ , hip default-language: Haskell2010 + Source-Repository head Type: git Location: https://github.com/lehins/hip.git diff --git a/images/downloaded/strawberry.gif b/images/downloaded/strawberry.gif new file mode 100644 Binary files /dev/null and b/images/downloaded/strawberry.gif differ diff --git a/images/strawberry.gif b/images/strawberry.gif new file mode 100644 Binary files /dev/null and b/images/strawberry.gif differ diff --git a/images/strawberry_backwards.gif b/images/strawberry_backwards.gif new file mode 100644 # file too large to diff: images/strawberry_backwards.gif diff --git a/src/Graphics/Image.hs b/src/Graphics/Image.hs --- a/src/Graphics/Image.hs +++ b/src/Graphics/Image.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-unused-imports -fno-warn-duplicate-exports #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} -- | @@ -65,27 +65,28 @@ -- makeImageR, makeImage, fromListsR, fromLists, toLists, -- * IO + module Graphics.Image.IO, -- ** Reading -- | Read supported files into an 'Image' with pixels in 'Double' -- precision. In order to read an image in a different representation, color -- space or precision, use 'readImage' or 'readImageExact' from - -- instead. While reading an - -- image, it's underlying representation can be specified by passing one of - -- `VU`, `RSU` or `RPU` as the first argument to @readImage*@ functions. Here is - -- a quick demonstration of how two images can be read as different - -- representations and later easily combined as their average. + -- instead. While reading an image, + -- it's underlying representation can be specified by passing one of `VU`, + -- `VS`, `RSU`, `RPU`, `RSS` or `RSU` as the first argument to @readImage*@ + -- functions. Here is a quick demonstration of how two images can be read as + -- different representations and later easily combined as their average. -- - -- >>> cluster <- readImageRGB RPU "images/cluster.jpg" + -- >>> cluster <- readImageRGB VU "images/cluster.jpg" -- >>> displayImage cluster -- >>> centaurus <- readImageRGB VU "images/centaurus.jpg" -- >>> displayImage centaurus - -- >>> displayImage ((cluster + exchange RPU centaurus) / 2) + -- >>> displayImage ((cluster + centaurus) / 2) -- -- <> <> <> -- - readImageY, readImageYA, readImageRGB, readImageRGBA, readImageExact, + readImageY, readImageYA, readImageRGB, readImageRGBA, -- ** Writing - writeImage, writeImageExact, displayImage, + writeImage, displayImage, -- * Accessors -- ** Dimensions rows, cols, dims, @@ -109,7 +110,7 @@ import qualified Data.Foldable as F import Graphics.Image.ColorSpace import Graphics.Image.IO -import Graphics.Image.Interface as I +import Graphics.Image.Interface as I hiding (Pixel) import Graphics.Image.Types as IP import Graphics.Image.Processing as IP @@ -150,25 +151,25 @@ -- | Read image as luma (brightness). readImageY :: Array arr Y Double => arr -> FilePath -> IO (Image arr Y Double) -readImageY _ = fmap (either error id) . readImage +readImageY _ = readImage' {-# INLINE readImageY #-} -- | Read image as luma with 'Alpha' channel. readImageYA :: Array arr YA Double => arr -> FilePath -> IO (Image arr YA Double) -readImageYA _ = fmap (either error id) . readImage +readImageYA _ = readImage' {-# INLINE readImageYA #-} -- | Read image in RGB colorspace. readImageRGB :: Array arr RGB Double => arr -> FilePath -> IO (Image arr RGB Double) -readImageRGB _ = fmap (either error id) . readImage +readImageRGB _ = readImage' {-# INLINE readImageRGB #-} -- | Read image in RGB colorspace with 'Alpha' channel. readImageRGBA :: Array arr RGBA Double => arr -> FilePath -> IO (Image arr RGBA Double) -readImageRGBA _ = fmap (either error id) . readImage +readImageRGBA _ = readImage' {-# INLINE readImageRGBA #-} @@ -247,6 +248,7 @@ -- supplied representation. fromListsR :: Array arr cs e => arr -> [[Pixel cs e]] -> Image arr cs e fromListsR _ = fromLists +{-# INLINE fromListsR #-} -- | Generates a nested list of pixels from an image. -- diff --git a/src/Graphics/Image/ColorSpace.hs b/src/Graphics/Image/ColorSpace.hs --- a/src/Graphics/Image/ColorSpace.hs +++ b/src/Graphics/Image/ColorSpace.hs @@ -5,6 +5,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} #if __GLASGOW_HASKELL__ >= 800 {-# OPTIONS_GHC -Wno-redundant-constraints #-} #endif @@ -17,36 +19,100 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace ( - -- * ColorSpace - ColorSpace, Pixel(..), AlphaSpace(..), Elevator(..), - -- * Operations on Pixels - eqTolPx, - -- * Luma - module Graphics.Image.ColorSpace.Y, - -- * RGB - module Graphics.Image.ColorSpace.RGB, - -- * HSI - module Graphics.Image.ColorSpace.HSI, - -- * CMYK - module Graphics.Image.ColorSpace.CMYK, - -- * YCbCr - module Graphics.Image.ColorSpace.YCbCr, - -- * Gray level - module Graphics.Image.ColorSpace.X, - -- * Binary - Binary, Bit, on, off, isOn, isOff, fromBool, complement, + -- * Pixels + -- ** Family of Pixels + -- | Pixel is a type family for all available color spaces. Below will be + -- listed all class instances pixels are installed in, as well as all pixel + -- constructors. + -- + -- >>> :t (PixelY 0) -- Black pixel in Luma + -- (PixelY 0) :: Num e => Pixel Y e + -- >>> PixelRGB 255 0 0 :: Pixel RGB Word8 -- Red pixel in RGB + -- + -- >>> PixelRGB 1 0 0 :: Pixel RGB Double -- Same red pixel in RGB with Double precision. + -- + -- >>> (PixelRGB 255 0 0 :: Pixel RGB Word8) == (toWord8 <$> (PixelRGB 1 0 0 :: Pixel RGB Double)) + -- True + -- + Pixel(..), + -- ** Luma (gray scale) + -- | Conversion to Luma from other color spaces. + toPixelY, toImageY, + toPixelYA, toImageYA, + -- ** RGB + -- | Conversion to RGB from other color spaces. + toPixelRGB, toImageRGB, + toPixelRGBA, toImageRGBA, + -- ** HSI + -- | Conversion to HSI from other color spaces. + toPixelHSI, toImageHSI, + toPixelHSIA, toImageHSIA, + -- ** CMYK + -- | Conversion to CMYK from other color spaces. + toPixelCMYK, toImageCMYK, + toPixelCMYKA, toImageCMYKA, + -- ** YCbCr + -- | Conversion to YCbCr from other color spaces. + toPixelYCbCr, toImageYCbCr, + toPixelYCbCrA, toImageYCbCrA, + -- ** Binary + -- | This is a Binary colorspace, pixel's of which can be created using + -- these __/constructors/__: + -- + -- [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is + -- displayed in black. + -- + -- [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is + -- displayed in white. + -- + -- Note, that values are inverted before writing to or reading from file, since + -- grayscale images represent black as a @0@ value and white as @1@ on a + -- @[0,1]@ scale. + -- + -- Binary pixels also behave as binary numbers with a size of 1-bit, for instance: + -- + -- >>> on + on -- equivalent to: 1 .|. 1 + -- + -- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0 + -- + -- >>> (on + on) - on + -- + -- + on, off, isOn, isOff, one, zero, fromBool, complement, toPixelBinary, fromPixelBinary, toImageBinary, fromImageBinary, - -- * Complex + -- ** Complex module Graphics.Image.ColorSpace.Complex, - -- * Re-exports + -- ** X + toPixelsX, fromPixelsX, + toImagesX, fromImagesX, + -- * ColorSpace + -- ** Operations on Pixels + eqTolPx, + -- ** Luma + Y(..), YA(..), + ToY, ToYA, + -- ** RGB + RGB(..), RGBA(..), + ToRGB, ToRGBA, + -- ** HSI + HSI(..), HSIA(..), + ToHSI, ToHSIA, + -- ** CMYK + CMYK(..), CMYKA(..), + ToCMYK, ToCMYKA, + -- ** YCbCr + YCbCr(..), YCbCrA(..), + ToYCbCr, ToYCbCrA, + -- ** Binary + Binary(..), Bit, + -- ** X + X(..), + -- * Useful re-exports Word8, Word16, Word32, Word64 ) where -import qualified Data.Complex as C import Data.Word -import Data.Int -import GHC.Float -import Graphics.Image.Interface hiding (map) +import Graphics.Image.Interface as I import Graphics.Image.ColorSpace.Binary import Graphics.Image.ColorSpace.RGB import Graphics.Image.ColorSpace.HSI @@ -55,16 +121,16 @@ import Graphics.Image.ColorSpace.Y import Graphics.Image.ColorSpace.YCbCr import Graphics.Image.ColorSpace.Complex -import qualified Graphics.Image.Interface as I (map) -- Binary: --- | Convert any pixel to binary pixel. -toPixelBinary :: (Eq (Pixel cs e), Num (Pixel cs e)) - => Pixel cs e -> Pixel Binary Bit -toPixelBinary px = if px == 0 then on else off -{-# INLINE toPixelBinary #-} +-- | Convert to a `Binary` image. +toImageBinary :: (Array arr cs e, Array arr Binary Bit) => + Image arr cs e + -> Image arr Binary Bit +toImageBinary = I.map toPixelBinary +{-# INLINE toImageBinary #-} -- | Convert a Binary pixel to Luma pixel fromPixelBinary :: Pixel Binary Bit -> Pixel Y Word8 @@ -72,14 +138,6 @@ {-# INLINE fromPixelBinary #-} --- | Convert any image to binary image. -toImageBinary :: (Array arr cs e, Array arr Binary Bit, Eq (Pixel cs e)) => - Image arr cs e - -> Image arr Binary Bit -toImageBinary = I.map toPixelBinary -{-# INLINE toImageBinary #-} - - -- | Convert a Binary image to Luma image fromImageBinary :: (Array arr Binary Bit, Array arr Y Word8) => Image arr Binary Bit @@ -97,43 +155,163 @@ {-# INLINE comp #-} {-# INLINE eqTolPx #-} +-- ToY -instance ToY X where - toPixelY (PixelX y) = PixelY y +-- | Conversion to Luma color space. +class ColorSpace cs e => ToY cs e where + + -- | Convert a pixel to Luma pixel. + toPixelY :: Pixel cs e -> Pixel Y Double + +-- | Convert an image to Luma image. +toImageY :: (ToY cs e, Array arr cs e, Array arr Y Double) => + Image arr cs e + -> Image arr Y Double +toImageY = I.map toPixelY +{-# INLINE toImageY #-} + + +instance Elevator e => ToY X e where + toPixelY (PixelX y) = PixelY $ toDouble y {-# INLINE toPixelY #-} +instance ToY Binary Bit where + toPixelY (PixelBinary b) = PixelY $ toDouble b + {-# INLINE toPixelY #-} + +instance Elevator e => ToY Y e where + toPixelY (PixelY y) = PixelY $ toDouble y + {-# INLINE toPixelY #-} + +instance Elevator e => ToY YA e where + toPixelY (PixelYA y _) = PixelY $ toDouble y + {-# INLINE toPixelY #-} + -- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @ -instance ToY RGB where - toPixelY (PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b) +instance Elevator e => ToY RGB e where + toPixelY (fmap toDouble -> (PixelRGB r g b)) = PixelY (0.299*r + 0.587*g + 0.114*b) {-# INLINE toPixelY #-} -instance ToYA RGBA where +instance Elevator e => ToY RGBA e where + toPixelY = toPixelY . dropAlpha + {-# INLINE toPixelY #-} -instance ToY HSI where - toPixelY = toPixelY . toPixelRGB +instance Elevator e => ToY HSI e where + toPixelY = toPixelY . toPixelRGB . fmap toDouble {-# INLINE toPixelY #-} -instance ToYA HSIA where +instance Elevator e => ToY HSIA e where + toPixelY = toPixelY . dropAlpha + {-# INLINE toPixelY #-} -instance ToY CMYK where - toPixelY = toPixelY . toPixelRGB +instance Elevator e => ToY CMYK e where + toPixelY = toPixelY . toPixelRGB . fmap toDouble {-# INLINE toPixelY #-} - -instance ToY YCbCr where - toPixelY (PixelYCbCr y _ _) = PixelY y +instance Elevator e => ToY CMYKA e where + toPixelY = toPixelY . toPixelRGB . fmap toDouble . dropAlpha {-# INLINE toPixelY #-} - -instance ToYA YCbCrA where - -instance ToRGB Y where - toPixelRGB (PixelY g) = promote g + +instance Elevator e => ToY YCbCr e where + toPixelY (PixelYCbCr y _ _) = PixelY $ toDouble y + {-# INLINE toPixelY #-} + +instance Elevator e => ToY YCbCrA e where + toPixelY (PixelYCbCrA y _ _ _) = PixelY $ toDouble y + {-# INLINE toPixelY #-} + + +-- ToYA + +-- | Conversion to Luma from another color space. +class ToY cs e => ToYA cs e where + + -- | Convert a pixel to Luma pixel with Alpha. + toPixelYA :: Pixel cs e -> Pixel YA Double + toPixelYA = addAlpha 1 . toPixelY + {-# INLINE toPixelYA #-} + +-- | Convert an image to Luma image with Alpha. +toImageYA :: (ToYA cs e, Array arr cs e, Array arr YA Double) => + Image arr cs e + -> Image arr YA Double +toImageYA = I.map toPixelYA +{-# INLINE toImageYA #-} + + +instance ToY Y e => ToYA Y e + +instance ToYA Binary Bit where + toPixelYA(PixelBinary b) = PixelYA (toDouble b) 1 + {-# INLINE toPixelYA #-} + +instance Elevator e => ToYA YA e where + toPixelYA = fmap toDouble + {-# INLINE toPixelYA #-} + +instance ToY RGB e => ToYA RGB e + +instance Elevator e => ToYA RGBA e where + toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px)) + {-# INLINE toPixelYA #-} + +instance ToY HSI e => ToYA HSI e + +instance Elevator e => ToYA HSIA e where + toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px)) + {-# INLINE toPixelYA #-} + +instance ToY CMYK e => ToYA CMYK e + +instance Elevator e => ToYA CMYKA e where + toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px)) + {-# INLINE toPixelYA #-} + +instance ToY YCbCr e => ToYA YCbCr e + +instance Elevator e => ToYA YCbCrA e where + toPixelYA !px = addAlpha (toDouble $ getAlpha px) (toPixelY (dropAlpha px)) + {-# INLINE toPixelYA #-} + +-- ToRGB + + +-- | Conversion to `RGB` color space. +class ColorSpace cs e => ToRGB cs e where + + -- | Convert to an `RGB` pixel. + toPixelRGB :: Pixel cs e -> Pixel RGB Double + +-- | Convert to an `RGB` image. +toImageRGB :: (ToRGB cs e, Array arr cs e, Array arr RGB Double) => + Image arr cs e + -> Image arr RGB Double +toImageRGB = I.map toPixelRGB +{-# INLINE toImageRGB #-} + + +instance ToRGB Binary Bit where + toPixelRGB (PixelBinary b) = pure $ toDouble b {-# INLINE toPixelRGB #-} -instance ToRGBA YA where +instance Elevator e => ToRGB Y e where + toPixelRGB (PixelY g) = promote $ toDouble g + {-# INLINE toPixelRGB #-} -instance ToRGB HSI where - toPixelRGB (PixelHSI h' s i) = getRGB (h'*2*pi) where +instance Elevator e => ToRGB YA e where + toPixelRGB = toPixelRGB . dropAlpha + {-# INLINE toPixelRGB #-} + +instance Elevator e => ToRGB RGB e where + toPixelRGB = fmap toDouble + {-# INLINE toPixelRGB #-} + +instance Elevator e => ToRGB RGBA e where + toPixelRGB = fmap toDouble . dropAlpha + {-# INLINE toPixelRGB #-} + +instance Elevator e => ToRGB HSI e where + toPixelRGB (fmap toDouble -> PixelHSI h' s i) = getRGB (h'*2*pi) where !is = i*s !second = i - is getFirst !a !b = i + is*cos a/cos b @@ -158,38 +336,111 @@ {-# INLINE getRGB #-} {-# INLINE toPixelRGB #-} -instance ToRGBA HSIA where +instance Elevator e => ToRGB HSIA e where + toPixelRGB = toPixelRGB . dropAlpha + {-# INLINE toPixelRGB #-} -instance ToRGB YCbCr where - - toPixelRGB (PixelYCbCr y cb cr) = PixelRGB r g b where +instance Elevator e => ToRGB YCbCr e where + toPixelRGB (fmap toDouble -> PixelYCbCr y cb cr) = PixelRGB r g b where !r = y + 1.402*(cr - 0.5) !g = y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5) !b = y + 1.772*(cb - 0.5) {-# INLINE toPixelRGB #-} -instance ToRGBA YCbCrA where - -instance ToRGB CMYK where +instance Elevator e => ToRGB YCbCrA e where + toPixelRGB = toPixelRGB . dropAlpha + {-# INLINE toPixelRGB #-} - toPixelRGB (PixelCMYK c m y k) = PixelRGB r g b where +instance Elevator e => ToRGB CMYK e where + toPixelRGB (fmap toDouble -> PixelCMYK c m y k) = PixelRGB r g b where !r = (1-c)*(1-k) !g = (1-m)*(1-k) !b = (1-y)*(1-k) {-# INLINE toPixelRGB #-} - -instance ToRGBA CMYKA where +instance Elevator e => ToRGB CMYKA e where + toPixelRGB = toPixelRGB . dropAlpha + {-# INLINE toPixelRGB #-} + + +-- ToRGBA + +-- | Conversion to `RGBA` from another color space with Alpha channel. +class ToRGB cs e => ToRGBA cs e where + + -- | Convert to an `RGBA` pixel. + toPixelRGBA :: Pixel cs e -> Pixel RGBA Double + toPixelRGBA = addAlpha 1 . toPixelRGB + {-# INLINE toPixelRGBA #-} + +-- | Convert to an `RGBA` image. +toImageRGBA :: (ToRGBA cs e, Array arr cs e, Array arr RGBA Double) => + Image arr cs e + -> Image arr RGBA Double +toImageRGBA = I.map toPixelRGBA +{-# INLINE toImageRGBA #-} + + +instance ToRGBA Binary Bit + +instance ToRGB Y e => ToRGBA Y e + +instance Elevator e => ToRGBA YA e where + toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) + {-# INLINE toPixelRGBA #-} + +instance ToRGB RGB e => ToRGBA RGB e + +instance Elevator e => ToRGBA RGBA e where + toPixelRGBA = fmap toDouble + {-# INLINE toPixelRGBA #-} + +instance ToRGB HSI e => ToRGBA HSI e + +instance Elevator e => ToRGBA HSIA e where + toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) + {-# INLINE toPixelRGBA #-} + +instance ToRGB CMYK e => ToRGBA CMYK e + +instance Elevator e => ToRGBA CMYKA e where + toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) + {-# INLINE toPixelRGBA #-} + +instance ToRGB YCbCr e => ToRGBA YCbCr e + +instance Elevator e => ToRGBA YCbCrA e where + toPixelRGBA !px = addAlpha (toDouble $ getAlpha px) (toPixelRGB (dropAlpha px)) + {-# INLINE toPixelRGBA #-} + + +-- ToHSI + +-- | Conversion to `HSI` color space. +class ColorSpace cs e => ToHSI cs e where + + -- | Convert to an `HSI` pixel. + toPixelHSI :: Pixel cs e -> Pixel HSI Double + +-- | Convert to an `HSI` image. +toImageHSI :: (ToHSI cs e, Array arr cs e, Array arr HSI Double) => + Image arr cs e + -> Image arr HSI Double +toImageHSI = I.map toPixelHSI +{-# INLINE toImageHSI #-} + -instance ToHSI Y where - toPixelHSI (PixelY g) = PixelHSI 0 0 g +instance Elevator e => ToHSI Y e where + toPixelHSI (PixelY y) = PixelHSI 0 0 $ toDouble y {-# INLINE toPixelHSI #-} -instance ToHSIA YA where - -instance ToHSI RGB where - toPixelHSI (PixelRGB r g b) = PixelHSI h s i where +instance Elevator e => ToHSI YA e where + toPixelHSI = toPixelHSI . dropAlpha + {-# INLINE toPixelHSI #-} + +instance Elevator e => ToHSI RGB e where + toPixelHSI (fmap toDouble -> PixelRGB r g b) = PixelHSI h s i where !h' = atan2 y x !h = (if h' < 0 then h' + 2*pi else h') / (2*pi) !s = if i == 0 then 0 else 1 - minimum [r, g, b] / i @@ -197,281 +448,308 @@ !x = (2*r - g - b) / 2.449489742783178 !y = (g - b) / 1.4142135623730951 {-# INLINE toPixelHSI #-} - -instance ToHSIA RGBA where +instance Elevator e => ToHSI RGBA e where + toPixelHSI = toPixelHSI . dropAlpha + {-# INLINE toPixelHSI #-} -instance ToYCbCr RGB where +instance Elevator e => ToHSI HSI e where + toPixelHSI = fmap toDouble + {-# INLINE toPixelHSI #-} - toPixelYCbCr (PixelRGB r g b) = PixelYCbCr y cb cr where - !y = 0.299*r + 0.587*g + 0.114*b - !cb = 0.5 - 0.168736*r - 0.331264*g + 0.5*b - !cr = 0.5 + 0.5*r - 0.418688*g - 0.081312*b - {-# INLINE toPixelYCbCr #-} +instance Elevator e => ToHSI HSIA e where + toPixelHSI = toPixelHSI . dropAlpha + {-# INLINE toPixelHSI #-} -instance ToYCbCrA RGBA where - +instance Elevator e => ToHSI YCbCr e where + toPixelHSI = toPixelHSI . toPixelRGB + {-# INLINE toPixelHSI #-} -instance ToCMYK RGB where +instance Elevator e => ToHSI YCbCrA e where + toPixelHSI = toPixelHSI . dropAlpha + {-# INLINE toPixelHSI #-} - toPixelCMYK (PixelRGB r g b) = PixelCMYK c m y k where +instance Elevator e => ToHSI CMYK e where + toPixelHSI = toPixelHSI . toPixelRGB + {-# INLINE toPixelHSI #-} + +instance Elevator e => ToHSI CMYKA e where + toPixelHSI = toPixelHSI . dropAlpha + {-# INLINE toPixelHSI #-} + + +-- ToHSIA + +-- | Conversion to `HSIA` from another color space with Alpha channel. +class ToHSI cs e => ToHSIA cs e where + + -- | Convert to an `HSIA` pixel. + toPixelHSIA :: Pixel cs e -> Pixel HSIA Double + toPixelHSIA = addAlpha 1 . toPixelHSI + {-# INLINE toPixelHSIA #-} + +-- | Convert to an `HSIA` image. +toImageHSIA :: (ToHSIA cs e, Array arr cs e, Array arr HSIA Double) => + Image arr cs e + -> Image arr HSIA Double +toImageHSIA = I.map toPixelHSIA +{-# INLINE toImageHSIA #-} + + +instance ToHSI Y e => ToHSIA Y e + +instance Elevator e => ToHSIA YA e where + toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) + {-# INLINE toPixelHSIA #-} + +instance ToHSI RGB e => ToHSIA RGB e + +instance Elevator e => ToHSIA RGBA e where + toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) + {-# INLINE toPixelHSIA #-} + +instance ToHSI HSI e => ToHSIA HSI e + +instance Elevator e => ToHSIA HSIA e where + toPixelHSIA = fmap toDouble + {-# INLINE toPixelHSIA #-} + +instance ToHSI CMYK e => ToHSIA CMYK e + +instance Elevator e => ToHSIA CMYKA e where + toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) + {-# INLINE toPixelHSIA #-} + +instance ToHSI YCbCr e => ToHSIA YCbCr e + +instance Elevator e => ToHSIA YCbCrA e where + toPixelHSIA !px = addAlpha (toDouble $ getAlpha px) (toPixelHSI (dropAlpha px)) + {-# INLINE toPixelHSIA #-} + + + +-- ToCMYK + +-- | Conversion to `CMYK` color space. +class ColorSpace cs e => ToCMYK cs e where + + -- | Convert to a `CMYK` pixel. + toPixelCMYK :: Pixel cs e -> Pixel CMYK Double + +-- | Convert to a `CMYK` image. +toImageCMYK :: (ToCMYK cs e, Array arr cs e, Array arr CMYK Double) => + Image arr cs e + -> Image arr CMYK Double +toImageCMYK = I.map toPixelCMYK +{-# INLINE toImageCMYK #-} + + +instance Elevator e => ToCMYK Y e where + toPixelCMYK = toPixelCMYK . toPixelRGB + {-# INLINE toPixelCMYK #-} + +instance Elevator e => ToCMYK YA e where + toPixelCMYK = toPixelCMYK . dropAlpha + {-# INLINE toPixelCMYK #-} + +instance Elevator e => ToCMYK RGB e where + toPixelCMYK (fmap toDouble -> PixelRGB r g b) = PixelCMYK c m y k where !c = (1 - r - k)/(1 - k) !m = (1 - g - k)/(1 - k) !y = (1 - b - k)/(1 - k) !k = 1 - max r (max g b) + {-# INLINE toPixelCMYK #-} -instance ToCMYKA RGBA where +instance Elevator e => ToCMYK RGBA e where + toPixelCMYK = toPixelCMYK . dropAlpha + {-# INLINE toPixelCMYK #-} +instance Elevator e => ToCMYK HSI e where + toPixelCMYK = toPixelCMYK . toPixelRGB + {-# INLINE toPixelCMYK #-} -dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b -dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div` - fromIntegral (maxBound :: b)) -{-# INLINE dropDown #-} +instance Elevator e => ToCMYK HSIA e where + toPixelCMYK = toPixelCMYK . dropAlpha + {-# INLINE toPixelCMYK #-} -raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b -raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a)) -{-# INLINE raiseUp #-} +instance Elevator e => ToCMYK CMYK e where + toPixelCMYK = fmap toDouble + {-# INLINE toPixelCMYK #-} +instance Elevator e => ToCMYK CMYKA e where + toPixelCMYK = toPixelCMYK . dropAlpha + {-# INLINE toPixelCMYK #-} -squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b -squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a) -{-# INLINE squashTo1 #-} +instance Elevator e => ToCMYK YCbCr e where + toPixelCMYK = toPixelCMYK . toPixelRGB + {-# INLINE toPixelCMYK #-} -stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b -stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e) +instance Elevator e => ToCMYK YCbCrA e where + toPixelCMYK = toPixelCMYK . dropAlpha + {-# INLINE toPixelCMYK #-} --- | Clamp a value to @[0, 1]@ range. -clamp01 :: (Ord a, Floating a) => a -> a -clamp01 !x = min (max 0 x) 1 -{-# INLINE clamp01 #-} +-- ToCMYKA +-- | Conversion to `CMYKA`. +class ToCMYK cs e => ToCMYKA cs e where -instance Elevator Word8 where + -- | Convert to a `CMYKA` pixel. + toPixelCMYKA :: Pixel cs e -> Pixel CMYKA Double + toPixelCMYKA = addAlpha 1 . toPixelCMYK + {-# INLINE toPixelCMYKA #-} - toWord8 = id - {-# INLINE toWord8 #-} - toWord16 = raiseUp - {-# INLINE toWord16 #-} - toWord32 = raiseUp - {-# INLINE toWord32 #-} - toWord64 = raiseUp - {-# INLINE toWord64 #-} - toFloat = squashTo1 - {-# INLINE toFloat #-} - toDouble = squashTo1 - {-# INLINE toDouble #-} - fromDouble = toWord8 - {-# INLINE fromDouble #-} +-- | Convert to a `CMYKA` image. +toImageCMYKA :: (ToCMYKA cs e, Array arr cs e, Array arr CMYKA Double) => + Image arr cs e + -> Image arr CMYKA Double +toImageCMYKA = I.map toPixelCMYKA +{-# INLINE toImageCMYKA #-} -instance Elevator Word16 where +instance ToCMYK Y e => ToCMYKA Y e - toWord8 = dropDown - {-# INLINE toWord8 #-} - toWord16 = id - {-# INLINE toWord16 #-} - toWord32 = raiseUp - {-# INLINE toWord32 #-} - toWord64 = raiseUp - {-# INLINE toWord64 #-} - toFloat = squashTo1 - {-# INLINE toFloat #-} - toDouble = squashTo1 - {-# INLINE toDouble #-} - fromDouble = toWord16 - {-# INLINE fromDouble #-} +instance Elevator e => ToCMYKA YA e where + toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) + {-# INLINE toPixelCMYKA #-} +instance ToCMYK RGB e => ToCMYKA RGB e -instance Elevator Word32 where +instance Elevator e => ToCMYKA RGBA e where + toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) + {-# INLINE toPixelCMYKA #-} - toWord8 = dropDown - {-# INLINE toWord8 #-} - toWord16 = dropDown - {-# INLINE toWord16 #-} - toWord32 = id - {-# INLINE toWord32 #-} - toWord64 = raiseUp - {-# INLINE toWord64 #-} - toFloat = squashTo1 - {-# INLINE toFloat #-} - toDouble = squashTo1 - {-# INLINE toDouble #-} - fromDouble = toWord32 - {-# INLINE fromDouble #-} +instance ToCMYK HSI e => ToCMYKA HSI e +instance Elevator e => ToCMYKA HSIA e where + toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) + {-# INLINE toPixelCMYKA #-} -instance Elevator Word64 where +instance ToCMYK CMYK e => ToCMYKA CMYK e - toWord8 = dropDown - {-# INLINE toWord8 #-} - toWord16 = dropDown - {-# INLINE toWord16 #-} - toWord32 = dropDown - {-# INLINE toWord32 #-} - toWord64 = id - {-# INLINE toWord64 #-} - toFloat = squashTo1 - {-# INLINE toFloat #-} - toDouble = squashTo1 - {-# INLINE toDouble #-} - fromDouble = toWord64 - {-# INLINE fromDouble #-} +instance Elevator e => ToCMYKA CMYKA e where + toPixelCMYKA = fmap toDouble + {-# INLINE toPixelCMYKA #-} +instance ToCMYK YCbCr e => ToCMYKA YCbCr e -instance Elevator Word where +instance Elevator e => ToCMYKA YCbCrA e where + toPixelCMYKA !px = addAlpha (toDouble $ getAlpha px) (toPixelCMYK (dropAlpha px)) + {-# INLINE toPixelCMYKA #-} - toWord8 = dropDown - {-# INLINE toWord8 #-} - toWord16 = dropDown - {-# INLINE toWord16 #-} - toWord32 = dropDown - {-# INLINE toWord32 #-} - toWord64 = fromIntegral - {-# INLINE toWord64 #-} - toFloat = squashTo1 - {-# INLINE toFloat #-} - toDouble = squashTo1 - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} -instance Elevator Int8 where - toWord8 = fromIntegral . (max 0) - {-# INLINE toWord8 #-} - toWord16 = raiseUp . (max 0) - {-# INLINE toWord16 #-} - toWord32 = raiseUp . (max 0) - {-# INLINE toWord32 #-} - toWord64 = raiseUp . (max 0) - {-# INLINE toWord64 #-} - toFloat = squashTo1 . (max 0) - {-# INLINE toFloat #-} - toDouble = squashTo1 . (max 0) - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} +-- ToYCbCr +-- | Conversion to `YCbCr` color space. +class ColorSpace cs e => ToYCbCr cs e where -instance Elevator Int16 where + -- | Convert to an `YCbCr` pixel. + toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double - toWord8 = dropDown . (max 0) - {-# INLINE toWord8 #-} - toWord16 = fromIntegral . (max 0) - {-# INLINE toWord16 #-} - toWord32 = raiseUp . (max 0) - {-# INLINE toWord32 #-} - toWord64 = raiseUp . (max 0) - {-# INLINE toWord64 #-} - toFloat = squashTo1 . (max 0) - {-# INLINE toFloat #-} - toDouble = squashTo1 . (max 0) - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} +-- | Convert to an `YCbCr` image. +toImageYCbCr :: (ToYCbCr cs e, Array arr cs e, Array arr YCbCr Double) => + Image arr cs e + -> Image arr YCbCr Double +toImageYCbCr = I.map toPixelYCbCr +{-# INLINE toImageYCbCr #-} -instance Elevator Int32 where - toWord8 = dropDown . (max 0) - {-# INLINE toWord8 #-} - toWord16 = dropDown . (max 0) - {-# INLINE toWord16 #-} - toWord32 = fromIntegral . (max 0) - {-# INLINE toWord32 #-} - toWord64 = raiseUp . (max 0) - {-# INLINE toWord64 #-} - toFloat = squashTo1 . (max 0) - {-# INLINE toFloat #-} - toDouble = squashTo1 . (max 0) - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} +instance Elevator e => ToYCbCr Y e where + toPixelYCbCr = toPixelYCbCr . toPixelRGB + {-# INLINE toPixelYCbCr #-} +instance Elevator e => ToYCbCr YA e where + toPixelYCbCr = toPixelYCbCr . dropAlpha + {-# INLINE toPixelYCbCr #-} -instance Elevator Int64 where +instance Elevator e => ToYCbCr RGB e where + toPixelYCbCr (fmap toDouble -> PixelRGB r g b) = PixelYCbCr y cb cr where + !y = 0.299*r + 0.587*g + 0.114*b + !cb = 0.5 - 0.168736*r - 0.331264*g + 0.5*b + !cr = 0.5 + 0.5*r - 0.418688*g - 0.081312*b + {-# INLINE toPixelYCbCr #-} - toWord8 = dropDown . (max 0) - {-# INLINE toWord8 #-} - toWord16 = dropDown . (max 0) - {-# INLINE toWord16 #-} - toWord32 = dropDown . (max 0) - {-# INLINE toWord32 #-} - toWord64 = fromIntegral . (max 0) - {-# INLINE toWord64 #-} - toFloat = squashTo1 . (max 0) - {-# INLINE toFloat #-} - toDouble = squashTo1 . (max 0) - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} +instance Elevator e => ToYCbCr RGBA e where + toPixelYCbCr = toPixelYCbCr . dropAlpha + {-# INLINE toPixelYCbCr #-} +instance Elevator e => ToYCbCr HSI e where + toPixelYCbCr = toPixelYCbCr . toPixelRGB + {-# INLINE toPixelYCbCr #-} -instance Elevator Int where +instance Elevator e => ToYCbCr HSIA e where + toPixelYCbCr = toPixelYCbCr . dropAlpha + {-# INLINE toPixelYCbCr #-} - toWord8 = dropDown . (max 0) - {-# INLINE toWord8 #-} - toWord16 = dropDown . (max 0) - {-# INLINE toWord16 #-} - toWord32 = dropDown . (max 0) - {-# INLINE toWord32 #-} - toWord64 = fromIntegral . (max 0) - {-# INLINE toWord64 #-} - toFloat = squashTo1 . (max 0) - {-# INLINE toFloat #-} - toDouble = squashTo1 . (max 0) - {-# INLINE toDouble #-} - fromDouble = stretch . clamp01 - {-# INLINE fromDouble #-} +instance Elevator e => ToYCbCr YCbCr e where + toPixelYCbCr = fmap toDouble + {-# INLINE toPixelYCbCr #-} +instance Elevator e => ToYCbCr YCbCrA e where + toPixelYCbCr = toPixelYCbCr . dropAlpha + {-# INLINE toPixelYCbCr #-} -instance Elevator Float where - toWord8 = stretch . clamp01 - {-# INLINE toWord8 #-} - toWord16 = stretch . clamp01 - {-# INLINE toWord16 #-} - toWord32 = stretch . clamp01 - {-# INLINE toWord32 #-} - toWord64 = stretch . clamp01 - {-# INLINE toWord64 #-} - toFloat = id - {-# INLINE toFloat #-} - toDouble = float2Double - {-# INLINE toDouble #-} - fromDouble = toFloat - {-# INLINE fromDouble #-} +instance Elevator e => ToYCbCr CMYK e where + toPixelYCbCr = toPixelYCbCr . toPixelRGB + {-# INLINE toPixelYCbCr #-} -instance Elevator Double where - toWord8 = stretch . clamp01 - {-# INLINE toWord8 #-} - toWord16 = stretch . clamp01 - {-# INLINE toWord16 #-} - toWord32 = stretch . clamp01 - {-# INLINE toWord32 #-} - toWord64 = stretch . clamp01 - {-# INLINE toWord64 #-} - toFloat = double2Float - {-# INLINE toFloat #-} - toDouble = id - {-# INLINE toDouble #-} - fromDouble = id - {-# INLINE fromDouble #-} +instance Elevator e => ToYCbCr CMYKA e where + toPixelYCbCr = toPixelYCbCr . dropAlpha + {-# INLINE toPixelYCbCr #-} -instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where - toWord8 = toWord8 . C.realPart - {-# INLINE toWord8 #-} - toWord16 = toWord16 . C.realPart - {-# INLINE toWord16 #-} - toWord32 = toWord32 . C.realPart - {-# INLINE toWord32 #-} - toWord64 = toWord64 . C.realPart - {-# INLINE toWord64 #-} - toFloat = toFloat . C.realPart - {-# INLINE toFloat #-} - toDouble = toDouble . C.realPart - {-# INLINE toDouble #-} - fromDouble = (C.:+ 0) . fromDouble - {-# INLINE fromDouble #-} +-- ToYCbCrA + + +-- | Conversion to `YCbCrA` from another color space with Alpha channel. +class ToYCbCr cs e => ToYCbCrA cs e where + + -- | Convert to an `YCbCrA` pixel. + toPixelYCbCrA :: Pixel cs e -> Pixel YCbCrA Double + toPixelYCbCrA = addAlpha 1 . toPixelYCbCr + {-# INLINE toPixelYCbCrA #-} + +-- | Convert to an `YCbCrA` image. +toImageYCbCrA :: (ToYCbCrA cs e, Array arr cs e, Array arr YCbCrA Double) => + Image arr cs e + -> Image arr YCbCrA Double +toImageYCbCrA = I.map toPixelYCbCrA +{-# INLINE toImageYCbCrA #-} + + + +instance ToYCbCr Y e => ToYCbCrA Y e + +instance Elevator e => ToYCbCrA YA e where + toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) + {-# INLINE toPixelYCbCrA #-} + +instance ToYCbCr RGB e => ToYCbCrA RGB e + + +instance ToYCbCr HSI e => ToYCbCrA HSI e + +instance Elevator e => ToYCbCrA HSIA e where + toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) + {-# INLINE toPixelYCbCrA #-} + +instance Elevator e => ToYCbCrA RGBA e where + toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) + {-# INLINE toPixelYCbCrA #-} + +instance ToYCbCr CMYK e => ToYCbCrA CMYK e + +instance Elevator e => ToYCbCrA CMYKA e where + toPixelYCbCrA !px = addAlpha (toDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px)) + {-# INLINE toPixelYCbCrA #-} + +instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e + +instance Elevator e => ToYCbCrA YCbCrA e where + toPixelYCbCrA = fmap toDouble + {-# INLINE toPixelYCbCrA #-} + + diff --git a/src/Graphics/Image/ColorSpace/Binary.hs b/src/Graphics/Image/ColorSpace/Binary.hs --- a/src/Graphics/Image/ColorSpace/Binary.hs +++ b/src/Graphics/Image/ColorSpace/Binary.hs @@ -15,7 +15,8 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.Binary ( - Binary(..), Bit(..), on, off, isOn, isOff, fromBool, + Binary(..), Bit(..), Pixel(..), on, off, isOn, isOff, fromBool, zero, one, + toPixelBinary, module Data.Bits ) where @@ -23,37 +24,16 @@ import Control.Monad import Data.Bits import Data.Word (Word8) -import Graphics.Image.Interface import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable import qualified Data.Vector.Generic as V import qualified Data.Vector.Generic.Mutable as M import qualified Data.Vector.Unboxed as U +import Graphics.Image.Interface --- | This is a Binary colorspace, pixel's of which can be created using --- these __/constructors/__: --- --- [@'on'@] Represents value @1@ or 'True'. It's a foreground pixel and is --- displayed in black. --- --- [@'off'@] Represents value @0@ or 'False'. It's a background pixel and is --- displayed in white. --- --- Note, that values are inverted before writing to or reading from file, since --- grayscale images represent black as a @0@ value and white as @1@ on a --- @[0,1]@ scale. --- --- Binary pixels also behave as binary numbers with a size of 1-bit, for instance: --- --- >>> on + on -- equivalent to: 1 .|. 1 --- --- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0 --- --- >>> (on + on) - on --- --- +-- | Binary Color Space, also known as bi-tonal. data Binary = Binary deriving (Eq, Enum, Bounded, Show, Typeable) @@ -63,6 +43,12 @@ newtype instance Pixel Binary Bit = PixelBinary Bit deriving (Ord, Eq) + +-- | Convert to a `Binary` pixel. +toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel Binary Bit +toPixelBinary px = if px == 0 then on else off + + instance Show (Pixel Binary Bit) where show (PixelBinary (Bit 0)) = "" show _ = "" @@ -140,17 +126,25 @@ popCount _ = 1 +zero :: Bit +zero = Bit 0 +{-# INLINE zero #-} + +one :: Bit +one = Bit 1 +{-# INLINE one #-} + -- | Represents value 'True' or @1@ in binary. Often also called a foreground -- pixel of an object. on :: Pixel Binary Bit -on = PixelBinary (Bit 1) +on = PixelBinary one {-# INLINE on #-} -- | Represents value 'False' or @0@ in binary. Often also called a background -- pixel. off :: Pixel Binary Bit -off = PixelBinary (Bit 0) +off = PixelBinary zero {-# INLINE off #-} @@ -203,7 +197,7 @@ foldlPx2 f !z (PixelBinary b1) (PixelBinary b2) = f z b1 b2 {-# INLINE foldlPx2 #-} - +-- | Values: @0@ and @1@ instance Elevator Bit where toWord8 (Bit 0) = 0 toWord8 _ = maxBound diff --git a/src/Graphics/Image/ColorSpace/CMYK.hs b/src/Graphics/Image/ColorSpace/CMYK.hs --- a/src/Graphics/Image/ColorSpace/CMYK.hs +++ b/src/Graphics/Image/ColorSpace/CMYK.hs @@ -14,8 +14,7 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.CMYK ( - CMYK(..), CMYKA(..), Pixel(..), - ToCMYK(..), ToCMYKA(..) + CMYK(..), CMYKA(..), Pixel(..) ) where import Prelude hiding (map) @@ -24,7 +23,6 @@ import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable - import Graphics.Image.Interface ------------ @@ -45,7 +43,7 @@ data instance Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq -instance (Elevator e, Typeable e) => ColorSpace CMYK e where +instance Elevator e => ColorSpace CMYK e where type Components CMYK e = (e, e, e, e) fromComponents !(c, m, y, k) = PixelCMYK c m y k @@ -98,7 +96,7 @@ instance Storable e => Storable (Pixel CMYK e) where - sizeOf _ = 3 * sizeOf (undefined :: e) + sizeOf _ = 4 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek p = do q <- return $ castPtr p @@ -127,36 +125,6 @@ deriving (Eq, Enum, Show, Bounded, Typeable) --- | Conversion to `CMYK` color space. -class ColorSpace cs Double => ToCMYK cs where - - -- | Convert to a `CMYK` pixel. - toPixelCMYK :: Pixel cs Double -> Pixel CMYK Double - - -- | Convert to a `CMYK` image. - toImageCMYK :: (Array arr cs Double, Array arr CMYK Double) => - Image arr cs Double - -> Image arr CMYK Double - toImageCMYK = map toPixelCMYK - {-# INLINE toImageCMYK #-} - - - --- | Conversion to `CMYKA` from another color space with Alpha channel. -class (ToCMYK (Opaque cs), AlphaSpace cs Double) => ToCMYKA cs where - - -- | Convert to a `CMYKA` pixel. - toPixelCMYKA :: Pixel cs Double -> Pixel CMYKA Double - toPixelCMYKA px = addAlpha (getAlpha px) (toPixelCMYK (dropAlpha px)) - {-# INLINE toPixelCMYKA #-} - - -- | Convert to a `CMYKA` image. - toImageCMYKA :: (Array arr cs Double, Array arr CMYKA Double) => - Image arr cs Double - -> Image arr CMYKA Double - toImageCMYKA = map toPixelCMYKA - {-# INLINE toImageCMYKA #-} - data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq @@ -165,7 +133,7 @@ "" -instance (Elevator e, Typeable e) => ColorSpace CMYKA e where +instance Elevator e => ColorSpace CMYKA e where type Components CMYKA e = (e, e, e, e, e) fromComponents !(c, m, y, k, a) = PixelCMYKA c m y k a @@ -200,7 +168,7 @@ {-# INLINE foldlPx2 #-} -instance (Elevator e, Typeable e) => AlphaSpace CMYKA e where +instance Elevator e => AlphaSpace CMYKA e where type Opaque CMYKA = CMYK getAlpha (PixelCMYKA _ _ _ _ a) = a @@ -233,7 +201,7 @@ instance Storable e => Storable (Pixel CMYKA e) where - sizeOf _ = 3 * sizeOf (undefined :: e) + sizeOf _ = 5 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek p = do q <- return $ castPtr p diff --git a/src/Graphics/Image/ColorSpace/Complex.hs b/src/Graphics/Image/ColorSpace/Complex.hs --- a/src/Graphics/Image/ColorSpace/Complex.hs +++ b/src/Graphics/Image/ColorSpace/Complex.hs @@ -13,11 +13,11 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.Complex ( - -- ** Rectangular form + -- *** Rectangular form Complex(..), (+:), realPart, imagPart, - -- ** Polar form + -- *** Polar form mkPolar, cis, polar, magnitude, phase, - -- ** Conjugate + -- *** Conjugate conjugate ) where diff --git a/src/Graphics/Image/ColorSpace/HSI.hs b/src/Graphics/Image/ColorSpace/HSI.hs --- a/src/Graphics/Image/ColorSpace/HSI.hs +++ b/src/Graphics/Image/ColorSpace/HSI.hs @@ -14,8 +14,7 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.HSI ( - HSI(..), HSIA(..), Pixel(..), - ToHSI(..), ToHSIA(..) + HSI(..), HSIA(..), Pixel(..) ) where import Prelude hiding (map) @@ -24,7 +23,6 @@ import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable - import Graphics.Image.Interface ----------- @@ -39,12 +37,12 @@ data instance Pixel HSI e = PixelHSI !e !e !e deriving Eq - + instance Show e => Show (Pixel HSI e) where show (PixelHSI h s i) = "" -instance (Elevator e, Typeable e) => ColorSpace HSI e where +instance Elevator e => ColorSpace HSI e where type Components HSI e = (e, e, e) toComponents (PixelHSI h s i) = (h, s, i) @@ -122,26 +120,11 @@ data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq --- | Conversion to `HSI` color space. -class ColorSpace cs Double => ToHSI cs where - - -- | Convert to an `HSI` pixel. - toPixelHSI :: Pixel cs Double -> Pixel HSI Double - - -- | Convert to an `HSI` image. - toImageHSI :: (Array arr cs Double, Array arr HSI Double) => - Image arr cs Double - -> Image arr HSI Double - toImageHSI = map toPixelHSI - {-# INLINE toImageHSI #-} - - - instance Show e => Show (Pixel HSIA e) where show (PixelHSIA h s i a) = "" -instance (Elevator e, Typeable e) => ColorSpace HSIA e where +instance Elevator e => ColorSpace HSIA e where type Components HSIA e = (e, e, e, e) toComponents (PixelHSIA h s i a) = (h, s, i, a) @@ -174,7 +157,7 @@ {-# INLINE foldlPx2 #-} -instance (Elevator e, Typeable e) => AlphaSpace HSIA e where +instance Elevator e => AlphaSpace HSIA e where type Opaque HSIA = HSI getAlpha (PixelHSIA _ _ _ a) = a @@ -185,22 +168,6 @@ {-# INLINE dropAlpha #-} --- | Conversion to `HSIA` from another color space with Alpha channel. -class (ToHSI (Opaque cs), AlphaSpace cs Double) => ToHSIA cs where - - -- | Convert to an `HSIA` pixel. - toPixelHSIA :: Pixel cs Double -> Pixel HSIA Double - toPixelHSIA px = addAlpha (getAlpha px) (toPixelHSI (dropAlpha px)) - {-# INLINE toPixelHSIA #-} - - -- | Convert to an `HSIA` image. - toImageHSIA :: (Array arr cs Double, Array arr HSIA Double) => - Image arr cs Double - -> Image arr HSIA Double - toImageHSIA = map toPixelHSIA - {-# INLINE toImageHSIA #-} - - instance Functor (Pixel HSIA) where fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a) {-# INLINE fmap #-} @@ -219,8 +186,7 @@ instance Storable e => Storable (Pixel HSIA e) where - - sizeOf _ = 3 * sizeOf (undefined :: e) + sizeOf _ = 4 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek p = do q <- return $ castPtr p diff --git a/src/Graphics/Image/ColorSpace/RGB.hs b/src/Graphics/Image/ColorSpace/RGB.hs --- a/src/Graphics/Image/ColorSpace/RGB.hs +++ b/src/Graphics/Image/ColorSpace/RGB.hs @@ -14,8 +14,7 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.RGB ( - RGB(..), RGBA(..), Pixel(..), - ToRGB(..), ToRGBA(..), + RGB(..), RGBA(..), Pixel(..) ) where import Prelude hiding (map) @@ -24,7 +23,6 @@ import Foreign.Storable import Data.Foldable import Data.Typeable (Typeable) - import Graphics.Image.Interface ----------- @@ -43,22 +41,7 @@ show (PixelRGB r g b) = "" --- | Conversion to `RGB` color space. -class ColorSpace cs Double => ToRGB cs where - - -- | Convert to an `RGB` pixel. - toPixelRGB :: Pixel cs Double -> Pixel RGB Double - - -- | Convert to an `RGB` image. - toImageRGB :: (Array arr cs Double, Array arr RGB Double) => - Image arr cs Double - -> Image arr RGB Double - toImageRGB = map toPixelRGB - {-# INLINE toImageRGB #-} - - - -instance (Elevator e, Typeable e) => ColorSpace RGB e where +instance Elevator e => ColorSpace RGB e where type Components RGB e = (e, e, e) toComponents (PixelRGB r g b) = (r, g, b) @@ -88,8 +71,6 @@ {-# INLINE foldlPx2 #-} - - instance Functor (Pixel RGB) where fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b) {-# INLINE fmap #-} @@ -107,10 +88,7 @@ {-# INLINE foldr #-} - - instance Storable e => Storable (Pixel RGB e) where - sizeOf _ = 3 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek !p = do @@ -126,8 +104,6 @@ pokeElemOff q 2 b - - ------------ --- RGBA --- ------------ @@ -146,23 +122,7 @@ show (PixelRGBA r g b a) = "" --- | Conversion to `RGBA` from another color space with Alpha channel. -class (ToRGB (Opaque cs), AlphaSpace cs Double) => ToRGBA cs where - - -- | Convert to an `RGBA` pixel. - toPixelRGBA :: Pixel cs Double -> Pixel RGBA Double - toPixelRGBA px = addAlpha (getAlpha px) (toPixelRGB (dropAlpha px)) - {-# INLINE toPixelRGBA #-} - - -- | Convert to an `RGBA` image. - toImageRGBA :: (Array arr cs Double, Array arr RGBA Double) => - Image arr cs Double - -> Image arr RGBA Double - toImageRGBA = map toPixelRGBA - {-# INLINE toImageRGBA #-} - - -instance (Elevator e, Typeable e) => ColorSpace RGBA e where +instance Elevator e => ColorSpace RGBA e where type Components RGBA e = (e, e, e, e) toComponents (PixelRGBA r g b a) = (r, g, b, a) @@ -195,7 +155,7 @@ {-# INLINE foldlPx2 #-} -instance (Elevator e, Typeable e) => AlphaSpace RGBA e where +instance Elevator e => AlphaSpace RGBA e where type Opaque RGBA = RGB getAlpha (PixelRGBA _ _ _ a) = a @@ -206,7 +166,6 @@ {-# INLINE dropAlpha #-} - instance Functor (Pixel RGBA) where fmap f (PixelRGBA r g b a) = PixelRGBA (f r) (f g) (f b) (f a) {-# INLINE fmap #-} @@ -221,11 +180,9 @@ foldr f !z (PixelRGBA r g b a) = f r (f g (f b (f a z))) {-# INLINE foldr #-} - instance Storable e => Storable (Pixel RGBA e) where - - sizeOf _ = 3 * sizeOf (undefined :: e) + sizeOf _ = 4 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek p = do q <- return $ castPtr p @@ -240,154 +197,3 @@ pokeElemOff q 1 g pokeElemOff q 2 b pokeElemOff q 3 a - - - - - ------------------------------------------------- - --- -- | Red, Green and Blue color space. --- data RGB16 = RedRGB16 --- | GreenRGB16 --- | BlueRGB16 deriving (Eq, Enum, Typeable, Show) - - --- --data instance Pixel RGB16 Word16 = PixelRGB16 !Word16 !Word16 !Word16 deriving Eq --- data instance Pixel RGB16 Word16 = PixelRGB16 --- {-# UNPACK #-} !Word16 --- {-# UNPACK #-} !Word16 --- {-# UNPACK #-} !Word16 deriving Eq --- --data instance Pixel RGB16 Word16 = PixelRGB16 - --- instance ColorSpace RGB16 Word16 where --- type Components RGB16 Word16 = (Word16, Word16, Word16) - --- promote !e = PixelRGB16 e e e --- {-# INLINE promote #-} - --- toComponents (PixelRGB16 r g b) = (r, g, b) --- {-# INLINE toComponents #-} - --- fromComponents !(r, g, b) = PixelRGB16 r g b --- {-# INLINE fromComponents #-} - - --- getPxC (PixelRGB16 r _ _) RedRGB16 = r --- getPxC (PixelRGB16 _ g _) GreenRGB16 = g --- getPxC (PixelRGB16 _ _ b) BlueRGB16 = b --- {-# INLINE getPxC #-} - --- setPxC (PixelRGB16 _ g b) RedRGB16 r = PixelRGB16 r g b --- setPxC (PixelRGB16 r _ b) GreenRGB16 g = PixelRGB16 r g b --- setPxC (PixelRGB16 r g _) BlueRGB16 b = PixelRGB16 r g b --- {-# INLINE setPxC #-} - --- mapPxC f (PixelRGB16 r g b) = PixelRGB16 (f RedRGB16 r) (f GreenRGB16 g) (f BlueRGB16 b) --- {-# INLINE mapPxC #-} - --- liftPx f (PixelRGB16 r g b) = PixelRGB16 (f r) (f g) (f b) --- {-# INLINE liftPx #-} - --- liftPx2 f (PixelRGB16 r1 g1 b1) (PixelRGB16 r2 g2 b2) = --- PixelRGB16 (f r1 r2) (f g1 g2) (f b1 b2) --- {-# INLINE liftPx2 #-} - --- foldlPx f !acc (PixelRGB16 r g b) = f (f (f acc r) g) b - - --- instance Num (Pixel RGB16 Word16) where --- (+) = liftPx2 (+) - --- (-) = liftPx2 (-) --- {-# INLINE (-) #-} - --- (*) = liftPx2 (*) --- {-# INLINE (*) #-} - --- abs = liftPx abs --- {-# INLINE abs #-} - --- signum = liftPx signum --- {-# INLINE signum #-} - --- fromInteger = promote . fromInteger --- {-# INLINE fromInteger #-} - - --- -- instance Fractional (Pixel RGB16 Word16) where --- -- (/) = liftPx2 (/) --- -- {-# INLINE (/) #-} - --- -- recip = liftPx recip --- -- {-# INLINE recip #-} - --- -- fromRational = promote . fromRational --- -- {-# INLINE fromRational #-} - - --- -- instance Floating (Pixel RGB16 Word16) where --- -- pi = promote pi --- -- {-# INLINE pi #-} - --- -- exp = liftPx exp --- -- {-# INLINE exp #-} - --- -- log = liftPx log --- -- {-# INLINE log #-} - --- -- sin = liftPx sin --- -- {-# INLINE sin #-} - --- -- cos = liftPx cos --- -- {-# INLINE cos #-} - --- -- asin = liftPx asin --- -- {-# INLINE asin #-} - --- -- atan = liftPx atan --- -- {-# INLINE atan #-} - --- -- acos = liftPx acos --- -- {-# INLINE acos #-} - --- -- sinh = liftPx sinh --- -- {-# INLINE sinh #-} - --- -- cosh = liftPx cosh --- -- {-# INLINE cosh #-} - --- -- asinh = liftPx asinh --- -- {-# INLINE asinh #-} - --- -- atanh = liftPx atanh --- -- {-# INLINE atanh #-} - --- -- acosh = liftPx acosh --- -- {-# INLINE acosh #-} - - --- -- instance Show RGB16 where --- -- show RedRGB16 = "Red" --- -- show GreenRGB16 = "Green" --- -- show BlueRGB16 = "Blue" - --- -- instance Show (Pixel RGB16 Word16) where --- -- show (PixelRGB16 r g b) = "" - - --- -- instance Storable (Pixel RGB16 Word16) where - --- -- sizeOf _ = 3 * sizeOf (undefined :: Word16) --- -- alignment _ = alignment (undefined :: Word16) --- -- peek p = do --- -- q <- return $ castPtr p --- -- r <- peek q --- -- g <- peekElemOff q 1 --- -- b <- peekElemOff q 2 --- -- return (PixelRGB16 r g b) --- -- poke p (PixelRGB16 r g b) = do --- -- q <- return $ castPtr p --- -- poke q r --- -- pokeElemOff q 1 g --- -- pokeElemOff q 2 b diff --git a/src/Graphics/Image/ColorSpace/X.hs b/src/Graphics/Image/ColorSpace/X.hs --- a/src/Graphics/Image/ColorSpace/X.hs +++ b/src/Graphics/Image/ColorSpace/X.hs @@ -14,7 +14,9 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.X ( - X(..), Pixel(..), toImagesX, fromImagesX + X(..), Pixel(..), + toPixelsX, toImagesX, + fromPixelsX, fromImagesX ) where import Prelude as P @@ -23,7 +25,6 @@ import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable - import Graphics.Image.Interface as I -- ^ This is a single channel colorspace, that is designed to separate Gray @@ -41,7 +42,7 @@ show (PixelX g) = "" -instance (Elevator e, Typeable e) => ColorSpace X e where +instance Elevator e => ColorSpace X e where type Components X e = e promote = PixelX @@ -104,6 +105,30 @@ q <- return $ castPtr p poke q g + +-- | Separate a Pixel into a list of components with 'X' pixels containing every +-- component from the pixel. +-- +-- >>> toPixelsX (PixelRGB 4 5 6) +-- [,,] +-- +toPixelsX :: ColorSpace cs e => Pixel cs e -> [Pixel X e] +toPixelsX = foldrPx ((:) . PixelX) [] + +-- | Combine a list of `X` pixels into a Pixel with a specified channel +-- order. Not the most efficient way to construct a pixel, but might prove +-- useful to someone. +-- +-- >>> fromPixelsX [(RedRGB, 3), (BlueRGB, 5), (GreenRGB, 4)] +-- +-- >>> fromPixelsX $ zip (enumFrom RedRGB) (toPixelsX $ PixelRGB 4 5 6) +-- +-- +fromPixelsX :: ColorSpace cs e => [(cs, Pixel X e)] -> Pixel cs e +fromPixelsX = foldl' f (promote 0) where + f !px (c, PixelX x) = setPxC px c x + + -- | Separate an image into a list of images with 'X' pixels containing every -- channel from the source image. -- @@ -127,7 +152,7 @@ -- -- For example here is a frog with swapped 'BlueRGB' and 'GreenRGB' channels. -- --- >>> writeImage "images/frog_rbg.jpg" $ fromImagesX [frog_red, frog_green, frog_blue] [RedRGB, BlueRGB, GreenRGB] +-- >>> writeImage "images/frog_rbg.jpg" $ fromImagesX [(RedRGB, frog_red), (BlueRGB, frog_green), (GreenRGB, frog_blue)] -- -- <> <> -- @@ -135,12 +160,12 @@ -- sometimes pretty useful, exactly the same effect as in example above can be -- achieved in a much simpler and a more efficient way: -- --- @ map (\(PixelRGB r g b) -> PixelRGB r b g) frog @ +-- @ `I.map` (\\(PixelRGB r g b) -> PixelRGB r b g) frog @ -- -fromImagesX :: forall arr cs e . (Array arr X e, Array arr cs e) => - [(cs, Image arr X e)] -> Image arr cs e +fromImagesX :: (Array arr X e, Array arr cs e) => + [(cs, Image arr X e)] -> Image arr cs e fromImagesX = fromXs 0 where - updateCh ch px (PixelX e) = setPxC px ch e + updateCh !ch !px (PixelX e) = setPxC px ch e {-# INLINE updateCh #-} fromXs img [] = img fromXs img ((c, i):xs) = fromXs (I.zipWith (updateCh c) img i) xs diff --git a/src/Graphics/Image/ColorSpace/Y.hs b/src/Graphics/Image/ColorSpace/Y.hs --- a/src/Graphics/Image/ColorSpace/Y.hs +++ b/src/Graphics/Image/ColorSpace/Y.hs @@ -14,8 +14,7 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.Y ( - Y(..), YA(..), Pixel(..), - ToY(..), ToYA(..) + Y(..), YA(..), Pixel(..) ) where import Prelude hiding (map) @@ -24,7 +23,6 @@ import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable - import Graphics.Image.Interface --------- @@ -37,23 +35,10 @@ newtype instance Pixel Y e = PixelY e deriving (Ord, Eq) --- | Conversion to Luma color space. -class ColorSpace cs Double => ToY cs where - - -- | Convert a pixel to Luma pixel. - toPixelY :: Pixel cs Double -> Pixel Y Double - - -- | Convert an image to Luma image. - toImageY :: (Array arr cs Double, Array arr Y Double) => - Image arr cs Double - -> Image arr Y Double - toImageY = map toPixelY - {-# INLINE toImageY #-} - instance Show e => Show (Pixel Y e) where show (PixelY g) = "" -instance (Elevator e, Typeable e) => ColorSpace Y e where +instance Elevator e => ColorSpace Y e where type Components Y e = e promote = PixelY {-# INLINE promote #-} @@ -130,23 +115,12 @@ data instance Pixel YA e = PixelYA !e !e deriving Eq --- | Conversion to Luma from another color space with Alpha channel. -class (ToY (Opaque cs), AlphaSpace cs Double) => ToYA cs where - -- | Convert a pixel to Luma pixel with Alpha. - toPixelYA :: Pixel cs Double -> Pixel YA Double - toPixelYA px = addAlpha (getAlpha px) (toPixelY (dropAlpha px)) - {-# INLINE toPixelYA #-} - - -- | Convert an image to Luma image with Alpha. - toImageYA :: (Array arr cs Double, Array arr YA Double) => - Image arr cs Double - -> Image arr YA Double - toImageYA = map toPixelYA - {-# INLINE toImageYA #-} +instance Show e => Show (Pixel YA e) where + show (PixelYA y a) = "" -instance (Elevator e, Typeable e) => ColorSpace YA e where +instance Elevator e => ColorSpace YA e where type Components YA e = (e, e) promote e = PixelYA e e {-# INLINE promote #-} @@ -172,7 +146,7 @@ {-# INLINE foldlPx2 #-} -instance (Elevator e, Typeable e) => AlphaSpace YA e where +instance Elevator e => AlphaSpace YA e where type Opaque YA = Y getAlpha (PixelYA _ a) = a diff --git a/src/Graphics/Image/ColorSpace/YCbCr.hs b/src/Graphics/Image/ColorSpace/YCbCr.hs --- a/src/Graphics/Image/ColorSpace/YCbCr.hs +++ b/src/Graphics/Image/ColorSpace/YCbCr.hs @@ -14,8 +14,7 @@ -- Portability : non-portable -- module Graphics.Image.ColorSpace.YCbCr ( - YCbCr(..), YCbCrA(..), Pixel(..), - ToYCbCr(..), ToYCbCrA(..) + YCbCr(..), YCbCrA(..), Pixel(..) ) where import Prelude hiding (map) @@ -24,10 +23,8 @@ import Data.Typeable (Typeable) import Foreign.Ptr import Foreign.Storable - import Graphics.Image.Interface - ------------- --- YCbCr --- ------------- @@ -41,12 +38,12 @@ data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq - + instance Show e => Show (Pixel YCbCr e) where show (PixelYCbCr y b r) = "" -instance (Elevator e, Typeable e) => ColorSpace YCbCr e where +instance Elevator e => ColorSpace YCbCr e where type Components YCbCr e = (e, e, e) promote !e = PixelYCbCr e e e @@ -124,12 +121,12 @@ data instance Pixel YCbCrA e = PixelYCbCrA !e !e !e !e deriving Eq - + instance Show e => Show (Pixel YCbCrA e) where show (PixelYCbCrA y b r a) = "" -instance (Elevator e, Typeable e) => ColorSpace YCbCrA e where +instance Elevator e => ColorSpace YCbCrA e where type Components YCbCrA e = (e, e, e, e) promote !e = PixelYCbCrA e e e e @@ -161,39 +158,8 @@ f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2 {-# INLINE foldlPx2 #-} - --- | Conversion to `YCbCr` color space. -class ColorSpace cs Double => ToYCbCr cs where - -- | Convert to an `YCbCr` pixel. - toPixelYCbCr :: Pixel cs Double -> Pixel YCbCr Double - - -- | Convert to an `YCbCr` image. - toImageYCbCr :: (Array arr cs Double, Array arr YCbCr Double) => - Image arr cs Double - -> Image arr YCbCr Double - toImageYCbCr = map toPixelYCbCr - {-# INLINE toImageYCbCr #-} - - --- | Conversion to `YCbCrA` from another color space with Alpha channel. -class (ToYCbCr (Opaque cs), AlphaSpace cs Double) => ToYCbCrA cs where - - -- | Convert to an `YCbCrA` pixel. - toPixelYCbCrA :: Pixel cs Double -> Pixel YCbCrA Double - toPixelYCbCrA px = addAlpha (getAlpha px) (toPixelYCbCr (dropAlpha px)) - {-# INLINE toPixelYCbCrA #-} - - -- | Convert to an `YCbCrA` image. - toImageYCbCrA :: (Array arr cs Double, Array arr YCbCrA Double) => - Image arr cs Double - -> Image arr YCbCrA Double - toImageYCbCrA = map toPixelYCbCrA - {-# INLINE toImageYCbCrA #-} - - - -instance (Elevator e, Typeable e) => AlphaSpace YCbCrA e where +instance Elevator e => AlphaSpace YCbCrA e where type Opaque YCbCrA = YCbCr getAlpha (PixelYCbCrA _ _ _ a) = a @@ -223,7 +189,7 @@ instance Storable e => Storable (Pixel YCbCrA e) where - sizeOf _ = 3 * sizeOf (undefined :: e) + sizeOf _ = 4 * sizeOf (undefined :: e) alignment _ = alignment (undefined :: e) peek p = do q <- return $ castPtr p diff --git a/src/Graphics/Image/IO.hs b/src/Graphics/Image/IO.hs --- a/src/Graphics/Image/IO.hs +++ b/src/Graphics/Image/IO.hs @@ -1,6 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Graphics.Image.IO -- Copyright : (c) Alexey Kuleshevich 2017 @@ -11,15 +12,16 @@ -- module Graphics.Image.IO ( -- * Reading - readImage, readImageExact, + readImage, readImage', + readImageExact, readImageExact', -- * Writing writeImage, writeImageExact, -- * Displaying ExternalViewer(..), displayImage, displayImageUsing, - displayImageFile, -- ** Common viewers + displayImageFile, defaultViewer, eogViewer, gpicviewViewer, @@ -29,7 +31,11 @@ module Graphics.Image.IO.Formats -- $supported - + + -- * Hands on examples + -- ** Animated GIF + + -- $animation ) where import Prelude as P hiding (readFile, writeFile) @@ -73,54 +79,75 @@ headMaybe ls = if null ls then Nothing else Just $ head ls -- | This function will try to guess an image format from file's extension, --- then it will attempt to read it as such. It will fall back onto the rest of +-- then it will attempt to decode it as such. It will fall back onto the rest of -- the supported formats and will try to read them regarless of file's -- extension. Whenever image cannot be decoded, 'Left' containing all errors for -- each attempted format will be returned, and 'Right' containing an image --- otherwise. Image will be read into a type signature specified 'ColorSpace' --- ('Graphics.Image.ColorSpace.Y', 'Graphics.Image.ColorSpace.YA', --- 'Graphics.Image.ColorSpace.RGB' and 'Graphics.Image.ColorSpace.RGBA' only) --- with 'Double' precision, while doing all necessary conversions. -readImage :: Readable (Image arr cs Double) InputFormat => - FilePath - -> IO (Either String (Image arr cs Double)) +-- otherwise. Image will be read with a type signature specified: +-- +-- >>> frog <- readImage "images/frog.jpg" :: IO (Either String (Image VS RGB Word8)) +-- >>> displayImage frog +-- +readImage :: forall arr cs e . + (Array VS cs e, Array arr cs e, + Readable (Image VS cs e) InputFormat) => + FilePath -- ^ File path for an image + -> IO (Either String (Image arr cs e)) readImage path = do imgstr <- B.readFile path let maybeFormat = guessFormat path :: Maybe InputFormat formats = enumFrom . toEnum $ 0 orderedFormats = maybe formats (\f -> f:P.filter (/=f) formats) maybeFormat + reader :: Either String (Image VS cs e) -> InputFormat -> IO (Either String (Image VS cs e)) reader (Left err) format = return $ either (Left . ((err++"\n")++)) Right (decode format imgstr) reader img _ = return img - M.foldM reader (Left "") orderedFormats + imgE <- M.foldM reader (Left "") orderedFormats + return $ fmap (exchange (undefined :: arr)) imgE --- | This function allows for reading any supported image in the exact colorspace --- and precision it is currently encoded in. For instance, frog image can be --- read into it's 'Graphics.Image.ColorSpace.YCbCr' colorspace with --- 'Graphics.Image.ColorSpace.Word8' precision and into any supported array --- representation. + +-- | Just like `readImage`, but will throw an exception if incorrect format is +-- detected. +readImage' :: (Array VS cs e, Array arr cs e, + Readable (Image VS cs e) InputFormat) => + FilePath -> IO (Image arr cs e) +readImage' path = either error id <$> readImage path + + +-- | This function allows for reading all supported image in their exact +-- colorspace and precision. Only `VS` image representation can be read +-- natively, but `Graphics.Image.exchange` can be use later to switch to a +-- different representation. For instance, "frog.jpg" image can be read into +-- it's 'Graphics.Image.ColorSpace.YCbCr' colorspace with +-- 'Graphics.Image.ColorSpace.Word8' precision: -- --- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP YCbCr Word8)) --- Right +-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image VS YCbCr Word8)) +-- Right -- -- The drawback here is that colorspace and precision has to match exactly, -- otherwise it will return an error: -- --- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image RP RGB Word8)) +-- >>> readImageExact JPG "images/frog.jpg" :: IO (Either String (Image VS RGB Word8)) -- Left "JuicyPixel decoding error: Input image is in YCbCr8 (Pixel YCbCr Word8), cannot convert it to RGB8 (Pixel RGB Word8) colorspace." -- --- Attempt to read an image in a particular color space that is not supported by --- the format, will result in a compile error. Refer to 'Readable' class for all --- images that can be decoded. -readImageExact :: Readable (Image arr cs e) format => +-- Any attempt to read an image in a color space, which is not supported by +-- supplied format, will result in a compile error. Refer to 'Readable' class +-- for all images that can be decoded. +readImageExact :: Readable img format => format -- ^ A file format that an image should be read as. See -- <#g:4 Supported Image Formats> -> FilePath -- ^ Location of an image. - -> IO (Either String (Image arr cs e)) + -> IO (Either String img) readImageExact format path = fmap (decode format) (B.readFile path) +-- | Just like `readImageExact`, but will throw an exception if incorrect format +-- is detected. +readImageExact' :: Readable b format => format -> FilePath -> IO b +readImageExact' format path = either error id <$> readImageExact format path + + -- | Just like 'readImage', this function will guess an output file format from the -- extension and write to file any image that is in one of 'Y', 'YA', 'RGB' or -- 'RGBA' color spaces with 'Double' precision. While doing necessary @@ -138,7 +165,7 @@ -> IO () writeImage path = BL.writeFile path . encode format [] . exchange VS where format = fromMaybe (error ("Could not guess output format. Use 'writeImageExact' "++ - "or supply a filename with supported format.")) + "or supply a filename with supported format.")) (guessFormat path :: Maybe OutputFormat) @@ -146,13 +173,13 @@ -- options. Precision and color space, that an image will be written as, is decided -- from image's type. Attempt to write image file in a format that does not -- support color space and precision combination will result in a compile error. -writeImageExact :: Writable (Image arr cs e) format => +writeImageExact :: Writable img format => format -- ^ A file format that an image should be saved in. See -- <#g:4 Supported Image Formats> -> [SaveOption format] -- ^ A list of format specific options. -> FilePath -- ^ Location where an image should be written. - -> (Image arr cs e) -- ^ An image to write. Can be a list of images in case + -> img -- ^ An image to write. Can be a list of images in case -- of formats supporting animation. -> IO () writeImageExact format opts path = BL.writeFile path . encode format opts @@ -160,7 +187,8 @@ -- | An image is written as a @.tiff@ file into an operating system's temporary -- directory and passed as an argument to the external viewer program. -displayImageUsing :: Writable (Image arr cs e) TIF => +displayImageUsing :: (Array VS cs e, Array arr cs e, + Writable (Image VS cs e) TIF) => ExternalViewer -- ^ External viewer to use -> Bool -- ^ Should the call be blocking -> Image arr cs e -- ^ Image to display @@ -172,7 +200,7 @@ bracket (openBinaryTempFile tmpDir "tmp-img.tiff") (hClose . snd) (\ (imgPath, imgHandle) -> do - BL.hPut imgHandle $ encode TIF [] img + BL.hPut imgHandle $ encode TIF [] $ exchange VS img hClose imgHandle displayImageFile viewer imgPath) if block @@ -188,21 +216,16 @@ where (argsBefore, argsAfter) = splitAt ix args -{- | Makes a call to an external viewer that is set as a default image viewer by -the OS. This is a non-blocking function call, so it will take some time before -an image will appear. - - >>> frog <- readImageRGB VU "images/frog.jpg" - >>> displayImage frog - --} +-- | Makes a call to an external viewer that is set as a default image viewer by +-- the OS. This is a non-blocking function call, so it might take some time +-- before an image will appear. displayImage :: (Array VS cs e, Array arr cs e, Writable (Image VS cs e) TIF) => Image arr cs e -- ^ Image to be displayed -> IO () -displayImage = displayImageUsing defaultViewer False . exchange VS - +displayImage = displayImageUsing defaultViewer False +-- | Default viewer is inferred from the operating system. defaultViewer :: ExternalViewer defaultViewer = #if defined(OS_Win32) @@ -216,82 +239,86 @@ #endif --- | @eog /tmp/hip/img.tiff@ +-- | @eog \/tmp\/hip\/img.tiff@ +-- -- eogViewer :: ExternalViewer eogViewer = ExternalViewer "eog" [] 0 --- | @feh --fullscreen --auto-zoom /tmp/hip/img.tiff@ +-- | @feh --fullscreen --auto-zoom \/tmp\/hip\/img.tiff@ +-- -- fehViewer :: ExternalViewer fehViewer = ExternalViewer "feh" ["--fullscreen", "--auto-zoom"] 2 --- | @gpicview /tmp/hip/img.tiff@ +-- | @gpicview \/tmp\/hip\/img.tiff@ +-- -- gpicviewViewer :: ExternalViewer gpicviewViewer = ExternalViewer "gpicview" [] 0 --- | @gimp /tmp/hip/img.tiff@ +-- | @gimp \/tmp\/hip\/img.tiff@ +-- -- gimpViewer :: ExternalViewer gimpViewer = ExternalViewer "gimp" [] 0 - {- $supported Encoding and decoding of images is done using and packages. List of image formats that are currently supported, and their exact -'ColorSpace's and precision for reading and writing: +'ColorSpace's and precision for reading and writing without an implicit +conversion: * 'BMP': - * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') * 'GIF': - * __read__: ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('RGB' 'Word8') - * Also supports reading and writing animated images, when used as @['GIF']@ + * __read__: ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('RGB' 'Word8') + * Also supports reading and writing animated images, when used as @'GIFA'@ * 'HDR': - * __read__: ('RGB' 'Float') - * __write__: ('RGB' 'Float') + * __read__: ('RGB' 'Float') + * __write__: ('RGB' 'Float') * 'JPG': - * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), ('YCbCr', 'Word8') - * __write__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), + * __write__: ('Y' 'Word8'), ('YA', 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'), ('YCbCr', 'Word8') * 'PNG': * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') * 'TGA': - * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') - * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __read__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') + * __write__: ('Y' 'Word8'), ('RGB' 'Word8'), ('RGBA' 'Word8') * 'TIF': * __read__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16'), - ('CMYK' 'Word8'), ('CMYK' 'Word16') + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16'), + ('CMYK' 'Word8'), ('CMYK' 'Word16') * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'), - ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') - ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8') + ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16') + ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8') * 'PBM': @@ -305,8 +332,48 @@ * 'PPM': - * __read__: ('RGB' 'Word8'), ('RGB' 'Word16') + * __read__: ('RGB' 'Word8'), ('RGB' 'Word16') * Also supports sequence of images in one file, when read as @['PPM']@ -} + + +{- $animation + +JuicyPixels is capable of encoding/decoding all sorts of poular formats, one of +which is animated GIFs. Here I would like to present a short demonstration on +how it is possible to work with image seqences. + +<> + +So, we download and image, but it's a little bit too big, and it's in RGBA +colorspace. + +* Read an animated GIF as a list of images: + +>>> imgs <- readImageExact' GIFA "images/downloaded/strawberry.gif" :: IO [(GifDelay, Image VS RGBA Word8)] + +* convert to `RGB` colorspace by dropping alpha channel and increasing precision, +since we cannot write GIFs in RGBA colorspace: + +>>> let imgsRGB = fmap (fmap toImageRGB) imgs + +* if `toImageRGB` hadn't increased the precision to `Double` in the previous + step, `Bilinear` interpolation would have simply destroyed the image quality + in this step. Scale all images in the sequence by a half: + +>>> let imgsRGBsmall = fmap (fmap (scale Bilinear Edge (0.5, 0.5))) imgsRGB + +* Here we save the sequence as a new animated image. We don't need to drop + precision back to `Word8`, it will be taken care for us: + +>>> writeImageExact GIFA [GIFALooping LoopingForever] "images/strawberry.gif" imgsRGBsmall + +* Now lets extend the animation a bit: + +>>> writeImageExact GIFA [GIFALooping LoopingForever] "images/strawberry_backwards.gif" (imgsRGBsmall ++ reverse imgsRGBsmall) + +<> <> + +-} diff --git a/src/Graphics/Image/IO/Base.hs b/src/Graphics/Image/IO/Base.hs --- a/src/Graphics/Image/IO/Base.hs +++ b/src/Graphics/Image/IO/Base.hs @@ -17,10 +17,29 @@ import qualified Data.ByteString as B (ByteString) import qualified Data.ByteString.Lazy as BL (ByteString) +import Graphics.Image.ColorSpace -- | Used during converting pixels between libraries. class Convertible a b where convert :: a -> b + +-- Y (Double) + +instance ToY cs e => Convertible (Pixel cs e) (Pixel Y Double) where + convert = toPixelY + +instance ToYA cs e => Convertible (Pixel cs e) (Pixel YA Double) where + convert = toPixelYA + +-- RGB -> RGB (Double) + +instance ToRGB cs e => Convertible (Pixel cs e) (Pixel RGB Double) where + convert = toPixelRGB + +instance ToRGBA cs e => Convertible (Pixel cs e) (Pixel RGBA Double) where + convert = toPixelRGBA + + -- | Image file format. Helps in guessing image format using a file extension, -- as well as supplying format specific options during saving an image. diff --git a/src/Graphics/Image/IO/Formats.hs b/src/Graphics/Image/IO/Formats.hs --- a/src/Graphics/Image/IO/Formats.hs +++ b/src/Graphics/Image/IO/Formats.hs @@ -6,17 +6,18 @@ {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Graphics.Image.IO.Formats --- Copyright : (c) Alexey Kuleshevich 2016 +-- Copyright : (c) Alexey Kuleshevich 2017 -- License : BSD3 -- Maintainer : Alexey Kuleshevich -- Stability : experimental -- Portability : non-portable -- module Graphics.Image.IO.Formats ( - module Graphics.Image.IO.Formats.JuicyPixels, + module Graphics.Image.IO.Formats.JuicyPixels.Common, module Graphics.Image.IO.Formats.Netpbm, InputFormat(..), OutputFormat(..), Readable(..), Writable(..), ImageFormat(..), + Convertible(..) ) where import Graphics.Image.ColorSpace @@ -24,12 +25,13 @@ import Graphics.Image.Processing import Graphics.Image.Processing.Complex import Graphics.Image.IO.Base -import Graphics.Image.IO.Formats.JuicyPixels +import Graphics.Image.IO.Formats.JuicyPixels.Common +import Graphics.Image.IO.Formats.JuicyPixels.Readable() +import Graphics.Image.IO.Formats.JuicyPixels.Writable() import Graphics.Image.IO.Formats.Netpbm --- | A collection of all image formats that can be read into HIP images with --- 'Double' precision pixel channels. +-- | A collection of all image formats that can be read into HIP images. data InputFormat = InputBMP | InputGIF | InputHDR diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels.hs b/src/Graphics/Image/IO/Formats/JuicyPixels.hs deleted file mode 100644 --- a/src/Graphics/Image/IO/Formats/JuicyPixels.hs +++ /dev/null @@ -1,1076 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} --- | --- Module : Graphics.Image.IO.Formats.JuicyPixels --- Copyright : (c) Alexey Kuleshevich 2016 --- License : BSD3 --- Maintainer : Alexey Kuleshevich --- Stability : experimental --- Portability : non-portable --- -module Graphics.Image.IO.Formats.JuicyPixels ( - BMP(..), - GIF(..), JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..), - HDR(..), - JPG(..), - PNG(..), - TGA(..), - TIF(..), - SaveOption(..), - ) where - -import Prelude as P -import GHC.Float -import Data.Either -import qualified Data.Monoid as M (mempty) -import Graphics.Image.ColorSpace -import Graphics.Image.Interface as I -import Graphics.Image.Interface.Vector -import Graphics.Image.IO.Base -import qualified Data.ByteString as B (ByteString) -import qualified Data.ByteString.Lazy as BL (ByteString) -import qualified Codec.Picture as JP -import qualified Codec.Picture.Jpg as JP -import qualified Codec.Picture.Types as JP -import qualified Codec.Picture.ColorQuant as JP -import qualified Data.Vector.Storable as V - --- | Bitmap image with @.bmp@ extension. -data BMP = BMP - -instance ImageFormat BMP where - data SaveOption BMP - - ext _ = ".bmp" - - --- | Graphics Interchange Format image with @.gif@ extension. -data GIF = GIF - -instance ImageFormat GIF where - data SaveOption GIF = GIFPalette JP.PaletteOptions - - ext _ = ".gif" - -instance ImageFormat [GIF] where - data SaveOption [GIF] = GIFsPalette JP.PaletteOptions - | GIFsLooping JP.GifLooping - - ext _ = ext GIF - --- | High-dynamic-range image with @.hdr@ or @.pic@ extension. -data HDR = HDR - -instance ImageFormat HDR where - data SaveOption HDR - - ext _ = ".hdr" - - exts _ = [".hdr", ".pic"] - - --- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension. -data JPG = JPG - -instance ImageFormat JPG where - data SaveOption JPG = JPGQuality Word8 - - ext _ = ".jpg" - - exts _ = [".jpg", ".jpeg"] - - --- | Portable Network Graphics image with @.png@ extension. -data PNG = PNG - -instance ImageFormat PNG where - data SaveOption PNG - - ext _ = ".png" - - --- | Truevision Graphics Adapter image with .tga extension. -data TGA = TGA - -instance ImageFormat TGA where - data SaveOption TGA - - ext _ = ".tga" - - --- | Tagged Image File Format image with @.tif@ or @.tiff@ extension. -data TIF = TIF - -instance ImageFormat TIF where - data SaveOption TIF - - ext _ = ".tif" - - exts _ = [".tif", ".tiff"] - - --------------------------------------------------------------------------------- --- Converting to and from JuicyPixels ------------------------------------------ --------------------------------------------------------------------------------- - --- Y -> Y (Double) - -instance Convertible JP.Pixel8 (Pixel Y Double) where - convert = fmap toDouble . PixelY - -instance Convertible JP.Pixel16 (Pixel Y Double) where - convert = fmap toDouble . PixelY - -instance Convertible JP.PixelF (Pixel Y Double) where - convert = fmap toDouble . PixelY - -instance Convertible JP.PixelYA8 (Pixel Y Double) where - convert = convert . JP.dropTransparency - -instance Convertible JP.PixelYA16 (Pixel Y Double) where - convert = convert . JP.dropTransparency - -instance Convertible JP.Pixel8 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.Pixel16 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelF (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelYA8 (Pixel YA Double) where - convert (JP.PixelYA8 y a) = fmap toDouble (PixelYA y a) - -instance Convertible JP.PixelYA16 (Pixel YA Double) where - convert (JP.PixelYA16 y a) = fmap toDouble (PixelYA y a) - - --- Color -> Y (Double) - -instance Convertible JP.PixelRGB8 (Pixel Y Double) where - convert = toPixelY . (convert :: JP.PixelRGB8 -> Pixel RGB Double) - -instance Convertible JP.PixelRGB16 (Pixel Y Double) where - convert = toPixelY . (convert :: JP.PixelRGB16 -> Pixel RGB Double) - -instance Convertible JP.PixelRGBA8 (Pixel Y Double) where - convert = toPixelY . (convert :: JP.PixelRGBA8 -> Pixel RGB Double) - -instance Convertible JP.PixelRGBA16 (Pixel Y Double) where - convert = toPixelY . (convert :: JP.PixelRGBA16 -> Pixel RGB Double) - -instance Convertible JP.PixelRGBF (Pixel Y Double) where - convert = toPixelY . (convert :: JP.PixelRGBF -> Pixel RGB Double) - -instance Convertible JP.PixelCMYK8 (Pixel Y Double) where - convert = toPixelY . fmap toDouble . (convert :: JP.PixelCMYK8 -> Pixel CMYK Word8) - -instance Convertible JP.PixelCMYK16 (Pixel Y Double) where - convert = toPixelY . fmap toDouble . (convert :: JP.PixelCMYK16 -> Pixel CMYK Word16) - -instance Convertible JP.PixelYCbCr8 (Pixel Y Double) where - convert = convert . JP.computeLuma - --- Color -> YA (Double) - -instance Convertible JP.PixelRGB8 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGB16 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGBF (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelCMYK8 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelCMYK16 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelYCbCr8 (Pixel YA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGBA8 (Pixel YA Double) where - convert = toPixelYA . (convert :: JP.PixelRGBA8 -> Pixel RGBA Double) - -instance Convertible JP.PixelRGBA16 (Pixel YA Double) where - convert = toPixelYA . (convert :: JP.PixelRGBA16 -> Pixel RGBA Double) - - - --- Y -> RGB (Double) - -instance Convertible JP.Pixel8 (Pixel RGB Double) where - convert = promote . toDouble - -instance Convertible JP.Pixel16 (Pixel RGB Double) where - convert = promote . toDouble - -instance Convertible JP.PixelF (Pixel RGB Double) where - convert = promote . toDouble - -instance Convertible JP.PixelYA8 (Pixel RGB Double) where - convert = convert . JP.dropTransparency - -instance Convertible JP.PixelYA16 (Pixel RGB Double) where - convert = convert . JP.dropTransparency - --- Color -> RGB (Double) - -instance Convertible JP.PixelRGB8 (Pixel RGB Double) where - convert (JP.PixelRGB8 r g b) = fmap toDouble $ PixelRGB r g b - -instance Convertible JP.PixelRGB16 (Pixel RGB Double) where - convert (JP.PixelRGB16 r g b) = fmap toDouble $ PixelRGB r g b - -instance Convertible JP.PixelRGBA8 (Pixel RGB Double) where - convert = convert . JP.dropTransparency - -instance Convertible JP.PixelRGBA16 (Pixel RGB Double) where - convert = convert . JP.dropTransparency - -instance Convertible JP.PixelRGBF (Pixel RGB Double) where - convert (JP.PixelRGBF r g b) = - PixelRGB (float2Double r) (float2Double g) (float2Double b) - -instance Convertible JP.PixelYCbCr8 (Pixel RGB Double) where - convert = convert . (JP.convertPixel :: JP.PixelYCbCr8 -> JP.PixelRGB8) - -instance Convertible JP.PixelCMYK8 (Pixel RGB Double) where - convert = convert . (JP.convertPixel :: JP.PixelCMYK8 -> JP.PixelRGB8) - -instance Convertible JP.PixelCMYK16 (Pixel RGB Double) where - convert = convert . (JP.convertPixel :: JP.PixelCMYK16 -> JP.PixelRGB16) - --- Y -> RGBA (Double) - -instance Convertible JP.Pixel8 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.Pixel16 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelF (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelYA8 (Pixel RGBA Double) where - convert = toPixelRGBA . (convert :: JP.PixelYA8 -> Pixel YA Double) - -instance Convertible JP.PixelYA16 (Pixel RGBA Double) where - convert = toPixelRGBA . (convert :: JP.PixelYA16 -> Pixel YA Double) - --- Color -> RGBA (Double) - -instance Convertible JP.PixelRGB8 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGB16 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGBF (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelCMYK8 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelCMYK16 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelYCbCr8 (Pixel RGBA Double) where - convert = addAlpha 1 . convert - -instance Convertible JP.PixelRGBA8 (Pixel RGBA Double) where - convert (JP.PixelRGBA8 r g b a) = fmap toDouble $ PixelRGBA r g b a - -instance Convertible JP.PixelRGBA16 (Pixel RGBA Double) where - convert (JP.PixelRGBA16 r g b a) = fmap toDouble $ PixelRGBA r g b a - - ----- to JuicyPixels ----- - ----- Exact precision conversions - -instance Convertible JP.Pixel8 (Pixel Y Word8) where - convert = PixelY - -instance Convertible JP.Pixel16 (Pixel Y Word16) where - convert = PixelY - -instance Convertible JP.Pixel32 (Pixel Y Word32) where - convert = PixelY - -instance Convertible JP.PixelF (Pixel Y Float) where - convert = PixelY - -instance Convertible JP.PixelYA8 (Pixel YA Word8) where - convert (JP.PixelYA8 g a) = PixelYA g a - -instance Convertible JP.PixelYA16 (Pixel YA Word16) where - convert (JP.PixelYA16 g a) = PixelYA g a - -instance Convertible JP.PixelRGB8 (Pixel RGB Word8) where - convert (JP.PixelRGB8 r g b) = PixelRGB r g b - -instance Convertible JP.PixelRGB16 (Pixel RGB Word16) where - convert (JP.PixelRGB16 r g b) = PixelRGB r g b - -instance Convertible JP.PixelRGBF (Pixel RGB Float) where - convert (JP.PixelRGBF r g b) = PixelRGB r g b - -instance Convertible JP.PixelRGBA8 (Pixel RGBA Word8) where - convert (JP.PixelRGBA8 r g b a) = PixelRGBA r g b a - -instance Convertible JP.PixelRGBA16 (Pixel RGBA Word16) where - convert (JP.PixelRGBA16 r g b a) = PixelRGBA r g b a - -instance Convertible JP.PixelYCbCr8 (Pixel YCbCr Word8) where - convert (JP.PixelYCbCr8 y cb cr) = PixelYCbCr y cb cr - -instance Convertible JP.PixelCMYK8 (Pixel CMYK Word8) where - convert (JP.PixelCMYK8 c m y k) = PixelCMYK c m y k - -instance Convertible JP.PixelCMYK16 (Pixel CMYK Word16) where - convert (JP.PixelCMYK16 c m y k) = PixelCMYK c m y k - - - -instance Convertible (Pixel Y Word8) JP.Pixel8 where - convert (PixelY g) = g - -instance Convertible (Pixel Y Word16) JP.Pixel16 where - convert (PixelY g) = g - -instance Convertible (Pixel Y Word32) JP.Pixel32 where - convert (PixelY g) = g - -instance Convertible (Pixel Y Float) JP.PixelF where - convert (PixelY g) = g - -instance Convertible (Pixel YA Word8) JP.PixelYA8 where - convert (PixelYA g a) = JP.PixelYA8 g a - -instance Convertible (Pixel YA Word16) JP.PixelYA16 where - convert (PixelYA g a) = JP.PixelYA16 g a - -instance Convertible (Pixel RGB Word8) JP.PixelRGB8 where - convert (PixelRGB r g b) = JP.PixelRGB8 r g b - -instance Convertible (Pixel RGB Word16) JP.PixelRGB16 where - convert (PixelRGB r g b) = JP.PixelRGB16 r g b - -instance Convertible (Pixel RGB Float) JP.PixelRGBF where - convert (PixelRGB r g b) = JP.PixelRGBF r g b - -instance Convertible (Pixel RGBA Word8) JP.PixelRGBA8 where - convert (PixelRGBA r g b a) = JP.PixelRGBA8 r g b a - -instance Convertible (Pixel RGBA Word16) JP.PixelRGBA16 where - convert (PixelRGBA r g b a) = JP.PixelRGBA16 r g b a - - -instance Convertible (Pixel YCbCr Word8) JP.PixelYCbCr8 where - convert (PixelYCbCr y cb cr) = JP.PixelYCbCr8 y cb cr - -instance Convertible (Pixel CMYK Word8) JP.PixelCMYK8 where - convert (PixelCMYK c m y k) = JP.PixelCMYK8 c m y k - -instance Convertible (Pixel CMYK Word16) JP.PixelCMYK16 where - convert (PixelCMYK c m y k) = JP.PixelCMYK16 c m y k - - - --------------------------------------------------------------------------------- --- Decoding images using JuicyPixels ------------------------------------------ --------------------------------------------------------------------------------- - - --- BMP Format Reading - -instance Readable (Image VS Binary Bit) BMP where - decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeBitmap - -instance Readable (Image VS Y Word8) BMP where - decode _ = jpImageY8ToImage . JP.decodeBitmap - -instance Readable (Image VS RGB Word8) BMP where - decode _ = jpImageRGB8ToImage . JP.decodeBitmap - -instance Readable (Image VS RGBA Word8) BMP where - decode _ = jpImageRGBA8ToImage . JP.decodeBitmap - - - --- GIF Format Reading - -instance Readable (Image VS RGB Word8) GIF where - decode _ = jpImageRGB8ToImage . JP.decodeGif - -instance Readable (Image VS RGBA Word8) GIF where - decode _ = jpImageRGBA8ToImage . JP.decodeGif - - --- List of GIF Format frames Reading - -decodeGifs :: (Either String JP.DynamicImage -> Either String img) - -> B.ByteString -> Either String [img] -decodeGifs decoder = either Left decodeLS . JP.decodeGifImages where - decodeLS ls = if null errs then Right imgs else Left $ unlines errs where - (errs, imgs) = partitionEithers $ P.map (decoder . Right) ls - -instance Readable [Image VS RGB Word8] [GIF] where - decode _ = decodeGifs jpImageRGB8ToImage - -instance Readable [Image VS RGBA Word8] [GIF] where - decode _ = decodeGifs jpImageRGBA8ToImage - - --- HDR Format Reading - -instance Readable (Image VS RGB Float) HDR where - decode _ = jpImageRGBFToImage . JP.decodeHDR - - --- JPG Format Reading - -instance Readable (Image VS Y Word8) JPG where - decode _ = jpImageY8ToImage . JP.decodeJpeg - -instance Readable (Image VS YA Word8) JPG where - decode _ = jpImageYA8ToImage . JP.decodeJpeg - -instance Readable (Image VS RGB Word8) JPG where - decode _ = jpImageRGB8ToImage . JP.decodeJpeg - -instance Readable (Image VS CMYK Word8) JPG where - decode _ = jpImageCMYK8ToImage . JP.decodeJpeg - -instance Readable (Image VS YCbCr Word8) JPG where - decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg - - --- PNG Format Reading - -instance Readable (Image VS Binary Bit) PNG where - decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodePng - -instance Readable (Image VS Y Word8) PNG where - decode _ = jpImageY8ToImage . JP.decodePng - -instance Readable (Image VS Y Word16) PNG where - decode _ = jpImageY16ToImage . JP.decodePng - -instance Readable (Image VS YA Word8) PNG where - decode _ = jpImageYA8ToImage . JP.decodePng - -instance Readable (Image VS YA Word16) PNG where - decode _ = jpImageYA16ToImage . JP.decodePng - -instance Readable (Image VS RGB Word8) PNG where - decode _ = jpImageRGB8ToImage . JP.decodePng - -instance Readable (Image VS RGB Word16) PNG where - decode _ = jpImageRGB16ToImage . JP.decodePng - -instance Readable (Image VS RGBA Word8) PNG where - decode _ = jpImageRGBA8ToImage . JP.decodePng - -instance Readable (Image VS RGBA Word16) PNG where - decode _ = jpImageRGBA16ToImage . JP.decodePng - - --- TGA Format Reading - -instance Readable (Image VS Binary Bit) TGA where - decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTga - -instance Readable (Image VS Y Word8) TGA where - decode _ = jpImageY8ToImage . JP.decodeTga - -instance Readable (Image VS RGB Word8) TGA where - decode _ = jpImageRGB8ToImage . JP.decodeTga - -instance Readable (Image VS RGBA Word8) TGA where - decode _ = jpImageRGBA8ToImage . JP.decodeTga - - --- TIF Format Reading - -instance Readable (Image VS Binary Bit) TIF where - decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTiff - -instance Readable (Image VS Y Word8) TIF where - decode _ = jpImageY8ToImage . JP.decodeTiff - -instance Readable (Image VS Y Word16) TIF where - decode _ = jpImageY16ToImage . JP.decodeTiff - -instance Readable (Image VS YA Word8) TIF where - decode _ = jpImageYA8ToImage . JP.decodeTiff - -instance Readable (Image VS YA Word16) TIF where - decode _ = jpImageYA16ToImage . JP.decodeTiff - -instance Readable (Image VS RGB Word8) TIF where - decode _ = jpImageRGB8ToImage . JP.decodeTiff - -instance Readable (Image VS RGB Word16) TIF where - decode _ = jpImageRGB16ToImage . JP.decodeTiff - -instance Readable (Image VS RGBA Word8) TIF where - decode _ = jpImageRGBA8ToImage . JP.decodeTiff - -instance Readable (Image VS RGBA Word16) TIF where - decode _ = jpImageRGBA16ToImage . JP.decodeTiff - -instance Readable (Image VS CMYK Word8) TIF where - decode _ = jpImageCMYK8ToImage . JP.decodeTiff - -instance Readable (Image VS CMYK Word16) TIF where - decode _ = jpImageCMYK16ToImage . JP.decodeTiff - - --- To Double precision safe conversion - -instance Array arr Y Double => Readable (Image arr Y Double) BMP where - decode _ = jpDynamicImageToImage . JP.decodeBitmap - -instance Array arr YA Double => Readable (Image arr YA Double) BMP where - decode _ = jpDynamicImageToImage . JP.decodeBitmap - -instance Array arr RGB Double => Readable (Image arr RGB Double) BMP where - decode _ = jpDynamicImageToImage . JP.decodeBitmap - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) BMP where - decode _ = jpDynamicImageToImage . JP.decodeBitmap - - -instance Array arr Y Double => Readable (Image arr Y Double) GIF where - decode _ = jpDynamicImageToImage . JP.decodeGif - -instance Array arr YA Double => Readable (Image arr YA Double) GIF where - decode _ = jpDynamicImageToImage . JP.decodeGif - -instance Array arr RGB Double => Readable (Image arr RGB Double) GIF where - decode _ = jpDynamicImageToImage . JP.decodeGif - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) GIF where - decode _ = jpDynamicImageToImage . JP.decodeGif - - -instance Array arr Y Double => Readable [Image arr Y Double] [GIF] where - decode _ = decodeGifs jpDynamicImageToImage - -instance Array arr YA Double => Readable [Image arr YA Double] [GIF] where - decode _ = decodeGifs jpDynamicImageToImage - -instance Array arr RGB Double => Readable [Image arr RGB Double] [GIF] where - decode _ = decodeGifs jpDynamicImageToImage - -instance Array arr RGBA Double => Readable [Image arr RGBA Double] [GIF] where - decode _ = decodeGifs jpDynamicImageToImage - - -instance Array arr Y Double => Readable (Image arr Y Double) HDR where - decode _ = jpDynamicImageToImage . JP.decodeHDR - -instance Array arr YA Double => Readable (Image arr YA Double) HDR where - decode _ = jpDynamicImageToImage . JP.decodeHDR - -instance Array arr RGB Double => Readable (Image arr RGB Double) HDR where - decode _ = jpDynamicImageToImage . JP.decodeHDR - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) HDR where - decode _ = jpDynamicImageToImage . JP.decodeHDR - - -instance Array arr Y Double => Readable (Image arr Y Double) JPG where - decode _ = jpDynamicImageToImage . JP.decodeJpeg - -instance Array arr YA Double => Readable (Image arr YA Double) JPG where - decode _ = jpDynamicImageToImage . JP.decodeJpeg - -instance Array arr RGB Double => Readable (Image arr RGB Double) JPG where - decode _ = jpDynamicImageToImage . JP.decodeJpeg - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) JPG where - decode _ = jpDynamicImageToImage . JP.decodeJpeg - - -instance Array arr Y Double => Readable (Image arr Y Double) PNG where - decode _ = jpDynamicImageToImage . JP.decodePng - -instance Array arr YA Double => Readable (Image arr YA Double) PNG where - decode _ = jpDynamicImageToImage . JP.decodePng - -instance Array arr RGB Double => Readable (Image arr RGB Double) PNG where - decode _ = jpDynamicImageToImage . JP.decodePng - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) PNG where - decode _ = jpDynamicImageToImage . JP.decodePng - - -instance Array arr Y Double => Readable (Image arr Y Double) TGA where - decode _ = jpDynamicImageToImage . JP.decodeTga - -instance Array arr YA Double => Readable (Image arr YA Double) TGA where - decode _ = jpDynamicImageToImage . JP.decodeTga - -instance Array arr RGB Double => Readable (Image arr RGB Double) TGA where - decode _ = jpDynamicImageToImage . JP.decodeTga - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) TGA where - decode _ = jpDynamicImageToImage . JP.decodeTga - - -instance Array arr Y Double => Readable (Image arr Y Double) TIF where - decode _ = jpDynamicImageToImage . JP.decodeTiff - -instance Array arr YA Double => Readable (Image arr YA Double) TIF where - decode _ = jpDynamicImageToImage . JP.decodeTiff - -instance Array arr RGB Double => Readable (Image arr RGB Double) TIF where - decode _ = jpDynamicImageToImage . JP.decodeTiff - -instance Array arr RGBA Double => Readable (Image arr RGBA Double) TIF where - decode _ = jpDynamicImageToImage . JP.decodeTiff - - - --- General decoding and helper functions - -jpImageToImageUnsafe :: (Array VS cs e, JP.Pixel jpx) => - JP.Image jpx -> Image VS cs e -jpImageToImageUnsafe (JP.Image n m v) = fromVector (m, n) $ V.unsafeCast v - - - -jpImageToImageSafe :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) => - JP.Image jpx -> Image arr cs e -jpImageToImageSafe jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx - where getPx (y, x) = convert $ JP.pixelAt jimg x y - - -jpImageY8ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word8) -jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg - - -jpImageY16ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word16) -jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg - -{- -- No JuicyPixels images are actually read in this type -jpImageYFToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Float) -jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg) -jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg --} - -jpImageYA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word8) -jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg - - -jpImageYA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word16) -jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg - - -jpImageRGB8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word8) -jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg - - -jpImageRGB16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word16) -jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg - - -jpImageRGBFToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Float) -jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg - - -jpImageRGBA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word8) -jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg - - -jpImageRGBA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word16) -jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg - - -jpImageYCbCr8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YCbCr Word8) -jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg - - -jpImageCMYK8ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word8) -jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg - - -jpImageCMYK16ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word16) -jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImageUnsafe jimg) -jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg - - -jpDynamicImageToImage' :: (Convertible JP.PixelCMYK16 (Pixel cs e), - Convertible JP.PixelCMYK8 (Pixel cs e), - Convertible JP.PixelRGB16 (Pixel cs e), - Convertible JP.PixelRGB8 (Pixel cs e), - Convertible JP.PixelRGBA16 (Pixel cs e), - Convertible JP.PixelRGBA8 (Pixel cs e), - Convertible JP.PixelRGBF (Pixel cs e), - Convertible JP.PixelYA16 (Pixel cs e), - Convertible JP.PixelYA8 (Pixel cs e), - Convertible JP.PixelYCbCr8 (Pixel cs e), - Convertible JP.Pixel16 (Pixel cs e), - Convertible JP.Pixel8 (Pixel cs e), - Convertible JP.PixelF (Pixel cs e), - Array arr cs e) => - JP.DynamicImage -> Image arr cs e -jpDynamicImageToImage' (JP.ImageY8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageY16 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageYF jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageYA8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageYA16 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageRGB8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageRGB16 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageRGBF jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageRGBA8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageCMYK8 jimg) = jpImageToImageSafe jimg -jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = jpImageToImageSafe jimg - - -jpDynamicImageToImage :: (Convertible JP.PixelCMYK16 (Pixel cs e), - Convertible JP.PixelCMYK8 (Pixel cs e), - Convertible JP.PixelRGB16 (Pixel cs e), - Convertible JP.PixelRGB8 (Pixel cs e), - Convertible JP.PixelRGBA16 (Pixel cs e), - Convertible JP.PixelRGBA8 (Pixel cs e), - Convertible JP.PixelRGBF (Pixel cs e), - Convertible JP.PixelYA16 (Pixel cs e), - Convertible JP.PixelYA8 (Pixel cs e), - Convertible JP.PixelYCbCr8 (Pixel cs e), - Convertible JP.Pixel16 (Pixel cs e), - Convertible JP.Pixel8 (Pixel cs e), - Convertible JP.PixelF (Pixel cs e), Array arr cs e) => - Either String JP.DynamicImage -> Either String (Image arr cs e) -jpDynamicImageToImage = either jpError (Right . jpDynamicImageToImage') - - -jpImageShowCS :: JP.DynamicImage -> String -jpImageShowCS (JP.ImageY8 _) = "Y8 (Pixel Y Word8)" -jpImageShowCS (JP.ImageY16 _) = "Y16 (Pixel Y Word16)" -jpImageShowCS (JP.ImageYF _) = "YF (Pixel Y Float)" -jpImageShowCS (JP.ImageYA8 _) = "YA8 (Pixel YA Word8)" -jpImageShowCS (JP.ImageYA16 _) = "YA16 (Pixel YA Word16)" -jpImageShowCS (JP.ImageRGB8 _) = "RGB8 (Pixel RGB Word8)" -jpImageShowCS (JP.ImageRGB16 _) = "RGB16 (Pixel RGB Word16)" -jpImageShowCS (JP.ImageRGBF _) = "RGBF (Pixel RGB Float)" -jpImageShowCS (JP.ImageRGBA8 _) = "RGBA8 (Pixel RGBA Word8)" -jpImageShowCS (JP.ImageRGBA16 _) = "RGBA16 (Pixel RGBA Word16)" -jpImageShowCS (JP.ImageYCbCr8 _) = "YCbCr8 (Pixel YCbCr Word8)" -jpImageShowCS (JP.ImageCMYK8 _) = "CMYK8 (Pixel CMYK Word8)" -jpImageShowCS (JP.ImageCMYK16 _) = "CMYK16 (Pixel CMYK Word16)" - - -jpError :: String -> Either String a -jpError err = Left ("JuicyPixel decoding error: "++err) - - -jpCSError :: String -> Either String JP.DynamicImage -> Either String a -jpCSError _ (Left err) = jpError err -jpCSError cs (Right jimg) = - jpError $ - "Input image is in " ++ - jpImageShowCS jimg ++ ", cannot convert it to " ++ cs ++ " colorspace." - - --------------------------------------------------------------------------------- --- Encoding images using JuicyPixels ------------------------------------------- --------------------------------------------------------------------------------- - -instance Writable (Image VS Y Word8) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) id - -instance Writable (Image VS RGB Word8) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) id - -instance Writable (Image VS RGBA Word8) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) id - -instance Writable (Image VS Binary Bit) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary - -instance Writable (Image VS Y Double) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) - -instance Writable (Image VS YA Double) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) - ((fmap toWord8) . dropAlpha) - -instance Writable (Image VS RGB Double) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) - -instance Writable (Image VS RGBA Double) BMP where - encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8) - --- Writable GIF - -encodeGIF :: (Array VS cs' e, Array VS cs Word8) => - [SaveOption GIF] -> (Pixel cs' e -> Pixel cs Word8) - -> Image VS cs' e -> BL.ByteString -encodeGIF [] !conv = - either error id . uncurry JP.encodeGifImageWithPalette . - JP.palettize JP.defaultPaletteOptions . imageToJPImage (undefined :: JP.PixelRGB8) conv -encodeGIF (GIFPalette palOpts:_) !conv = - either error id . uncurry JP.encodeGifImageWithPalette . - JP.palettize palOpts . imageToJPImage (undefined :: JP.PixelRGB8) conv - - -instance Writable (Image VS RGB Word8) GIF where - encode _ opts = encodeGIF opts id - -instance Writable (Image VS Y Double) GIF where - encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB) - -instance Writable (Image VS YA Double) GIF where - encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB . dropAlpha) - -instance Writable (Image VS RGB Double) GIF where - encode _ opts = encodeGIF opts (fmap toWord8) - -instance Writable (Image VS RGBA Double) GIF where - encode _ opts = encodeGIF opts ((fmap toWord8) . dropAlpha) - - -encodeGIFs :: (Array VS cs' e, Array VS cs Word8) => - [SaveOption [GIF]] -> (Pixel cs' e -> Pixel cs Word8) - -> [(JP.GifDelay, Image VS cs' e)] -> BL.ByteString -encodeGIFs !opts !conv = - either error id . JP.encodeGifImages (getGIFsLoop opts) . P.map palletizeGif where - getGIFsLoop [] = JP.LoopingNever - getGIFsLoop (GIFsLooping loop:_) = loop - getGIFsLoop (_:xs) = getGIFsLoop xs - getGIFsPal [] = JP.defaultPaletteOptions - getGIFsPal (GIFsPalette palOpts:_) = palOpts - getGIFsPal (_:xs) = getGIFsPal xs - palletizeGif !(d, img) = (p, d, jimg) where - !(jimg, p) = JP.palettize (getGIFsPal opts) $ - imageToJPImage (undefined :: JP.PixelRGB8) conv img - - -instance Writable [(JP.GifDelay, Image VS RGB Word8)] [GIF] where - encode _ opts = encodeGIFs opts id - -instance Writable [(JP.GifDelay, Image VS RGB Double)] [GIF] where - encode _ opts = encodeGIFs opts (fmap toWord8) --- Writable HDR - -instance Writable (Image VS RGB Float) HDR where - encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) id - -instance Writable (Image VS Y Double) HDR where - encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) - (fmap toFloat . toPixelRGB) - -instance Writable (Image VS YA Double) HDR where - encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) - (fmap toFloat . toPixelRGB . dropAlpha) - -instance Writable (Image VS RGB Double) HDR where - encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) (fmap toFloat) - -instance Writable (Image VS RGBA Double) HDR where - encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) - (fmap toFloat . dropAlpha) - - --- Writable JPG - - -encodeJPG - :: (JP.JpgEncodable px, Array VS cs' e, Array VS cs (JP.PixelBaseComponent px)) => - [SaveOption JPG] - -> px - -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent px)) - -> Image VS cs' e - -> BL.ByteString -encodeJPG [] t conv = - JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage t conv -encodeJPG (JPGQuality q:_) t conv = - JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage t conv - - -instance Writable (Image VS Y Word8) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) id - -instance Writable (Image VS RGB Word8) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) id - -instance Writable (Image VS CMYK Word8) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.PixelCMYK8) id - -instance Writable (Image VS YCbCr Word8) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.PixelYCbCr8) id - -instance Writable (Image VS Y Double) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) (fmap toWord8) - -instance Writable (Image VS YA Double) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) - -instance Writable (Image VS RGB Double) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) (fmap toWord8) - -instance Writable (Image VS RGBA Double) JPG where - encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) ((fmap toWord8) . dropAlpha) - - --- Writable PNG - -instance Writable (Image VS Binary Bit) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary - -instance Writable (Image VS Y Word8) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) id - -instance Writable (Image VS Y Word16) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) id - -instance Writable (Image VS YA Word8) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA8) id - -instance Writable (Image VS YA Word16) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) id - -instance Writable (Image VS RGB Word8) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB8) id - -instance Writable (Image VS RGB Word16) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) id - -instance Writable (Image VS RGBA Word8) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA8) id - -instance Writable (Image VS RGBA Word16) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) id - - -instance Writable (Image VS Y Double) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) - -instance Writable (Image VS YA Double) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) - -instance Writable (Image VS RGB Double) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) - -instance Writable (Image VS RGBA Double) PNG where - encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16) - --- Writable TGA - -instance Writable (Image VS Binary Bit) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary - -instance Writable (Image VS Y Word8) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) id - -instance Writable (Image VS RGB Word8) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) id - -instance Writable (Image VS RGBA Word8) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) id - - -instance Writable (Image VS Y Double) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) - -instance Writable (Image VS YA Double) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) - -instance Writable (Image VS RGB Double) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) - -instance Writable (Image VS RGBA Double) TGA where - encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8) - --- Writable TIF - -instance Writable (Image VS Y Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) id - -instance Writable (Image VS Y Word16) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) id - -instance Writable (Image VS YA Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA8) id - -instance Writable (Image VS YA Word16) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) id - -instance Writable (Image VS RGB Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB8) id - -instance Writable (Image VS RGB Word16) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) id - -instance Writable (Image VS RGBA Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA8) id - -instance Writable (Image VS RGBA Word16) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) id - -instance Writable (Image VS YCbCr Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) id - -instance Writable (Image VS CMYK Word8) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK8) id - -instance Writable (Image VS CMYK Word16) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) id - - -instance Writable (Image VS Binary Bit) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary - -instance Writable (Image VS Y Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) - -instance Writable (Image VS YA Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) - -instance Writable (Image VS RGB Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) - -instance Writable (Image VS RGBA Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16) - -instance Writable (Image VS YCbCr Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) (fmap toWord8) - -instance Writable (Image VS CMYK Double) TIF where - encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) (fmap toWord16) - - - -imageToJPImage :: (JP.Pixel a, Array VS cs' e, Array VS cs (JP.PixelBaseComponent a)) => - a -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent a)) -> Image VS cs' e -> JP.Image a -imageToJPImage _ f !img = JP.Image n m $ V.unsafeCast $ toVector $ I.map f img where - !(m, n) = dims img -{-# INLINE imageToJPImage #-} - - - diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels/Common.hs b/src/Graphics/Image/IO/Formats/JuicyPixels/Common.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/Formats/JuicyPixels/Common.hs @@ -0,0 +1,112 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Image.IO.Formats.JuicyPixels.Common +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.IO.Formats.JuicyPixels.Common ( + BMP(..), + GIF(..), GIFA(..), + JP.GifDelay, JP.GifLooping(..), JP.PaletteOptions(..), JP.PaletteCreationMethod(..), + HDR(..), + JPG(..), + PNG(..), + TGA(..), + TIF(..), + SaveOption(..), + ) where + +import Graphics.Image.ColorSpace +import Graphics.Image.IO.Base +import qualified Codec.Picture as JP + + + + + +-- | Bitmap image with @.bmp@ extension. +data BMP = BMP + +instance ImageFormat BMP where + data SaveOption BMP + + ext _ = ".bmp" + + +-- | Graphics Interchange Format image with @.gif@ extension. +data GIF = GIF + +instance ImageFormat GIF where + data SaveOption GIF = GIFPalette JP.PaletteOptions + + ext _ = ".gif" + + + -- | Graphics Interchange Format animated image with @.gif@ extension. +data GIFA = GIFA + +instance ImageFormat GIFA where + data SaveOption GIFA = GIFAPalette JP.PaletteOptions + | GIFALooping JP.GifLooping + + ext _ = ext GIF + +-- | High-dynamic-range image with @.hdr@ or @.pic@ extension. +data HDR = HDR + +instance ImageFormat HDR where + data SaveOption HDR + + ext _ = ".hdr" + + exts _ = [".hdr", ".pic"] + + +-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension. +data JPG = JPG + +instance ImageFormat JPG where + data SaveOption JPG = JPGQuality Word8 + + ext _ = ".jpg" + + exts _ = [".jpg", ".jpeg"] + + +-- | Portable Network Graphics image with @.png@ extension. +data PNG = PNG + +instance ImageFormat PNG where + data SaveOption PNG + + ext _ = ".png" + + +-- | Truevision Graphics Adapter image with .tga extension. +data TGA = TGA + +instance ImageFormat TGA where + data SaveOption TGA + + ext _ = ".tga" + + +-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension. +data TIF = TIF + +instance ImageFormat TIF where + data SaveOption TIF + + ext _ = ".tif" + + exts _ = [".tif", ".tiff"] diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels/Readable.hs b/src/Graphics/Image/IO/Formats/JuicyPixels/Readable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/Formats/JuicyPixels/Readable.hs @@ -0,0 +1,568 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Image.IO.Formats.JuicyPixels.Readable +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.IO.Formats.JuicyPixels.Readable () where + +import Prelude as P + +import Graphics.Image.ColorSpace +import Graphics.Image.Interface as I +import Graphics.Image.Interface.Vector +import Graphics.Image.IO.Base +import Graphics.Image.IO.Formats.JuicyPixels.Common +import qualified Data.ByteString as B -- (ByteString) +import qualified Codec.Picture as JP +import qualified Codec.Picture.Types as JP +import qualified Codec.Picture.Gif as JP +import qualified Data.Vector.Storable as V + + +-------------------------------------------------------------------------------- +-- Converting to and from JuicyPixels ------------------------------------------ +-------------------------------------------------------------------------------- + +---- to JuicyPixels ----- + +---- Exact precision conversions + +instance Convertible JP.Pixel8 (Pixel Y Word8) where + convert = PixelY + +instance Convertible JP.Pixel16 (Pixel Y Word16) where + convert = PixelY + +instance Convertible JP.Pixel32 (Pixel Y Word32) where + convert = PixelY + +instance Convertible JP.PixelF (Pixel Y Float) where + convert = PixelY + +instance Convertible JP.PixelYA8 (Pixel YA Word8) where + convert (JP.PixelYA8 g a) = PixelYA g a + +instance Convertible JP.PixelYA16 (Pixel YA Word16) where + convert (JP.PixelYA16 g a) = PixelYA g a + +instance Convertible JP.PixelRGB8 (Pixel RGB Word8) where + convert (JP.PixelRGB8 r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGB16 (Pixel RGB Word16) where + convert (JP.PixelRGB16 r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGBF (Pixel RGB Float) where + convert (JP.PixelRGBF r g b) = PixelRGB r g b + +instance Convertible JP.PixelRGBA8 (Pixel RGBA Word8) where + convert (JP.PixelRGBA8 r g b a) = PixelRGBA r g b a + +instance Convertible JP.PixelRGBA16 (Pixel RGBA Word16) where + convert (JP.PixelRGBA16 r g b a) = PixelRGBA r g b a + +instance Convertible JP.PixelYCbCr8 (Pixel YCbCr Word8) where + convert (JP.PixelYCbCr8 y cb cr) = PixelYCbCr y cb cr + +instance Convertible JP.PixelCMYK8 (Pixel CMYK Word8) where + convert (JP.PixelCMYK8 c m y k) = PixelCMYK c m y k + +instance Convertible JP.PixelCMYK16 (Pixel CMYK Word16) where + convert (JP.PixelCMYK16 c m y k) = PixelCMYK c m y k + + + +instance Convertible (Pixel Y Word8) JP.Pixel8 where + convert (PixelY y) = y + +instance Convertible (Pixel Y Word16) JP.Pixel16 where + convert (PixelY y) = y + +instance Convertible (Pixel Y Word32) JP.Pixel32 where + convert (PixelY y) = y + +instance Convertible (Pixel Y Float) JP.PixelF where + convert (PixelY y) = y + +instance Convertible (Pixel YA Word8) JP.PixelYA8 where + convert (PixelYA y a) = JP.PixelYA8 y a + +instance Convertible (Pixel YA Word16) JP.PixelYA16 where + convert (PixelYA y a) = JP.PixelYA16 y a + +instance Convertible (Pixel RGB Word8) JP.PixelRGB8 where + convert (PixelRGB r g b) = JP.PixelRGB8 r g b + +instance Convertible (Pixel RGB Word16) JP.PixelRGB16 where + convert (PixelRGB r g b) = JP.PixelRGB16 r g b + +instance Convertible (Pixel RGB Float) JP.PixelRGBF where + convert (PixelRGB r g b) = JP.PixelRGBF r g b + +instance Convertible (Pixel RGBA Word8) JP.PixelRGBA8 where + convert (PixelRGBA r g b a) = JP.PixelRGBA8 r g b a + +instance Convertible (Pixel RGBA Word16) JP.PixelRGBA16 where + convert (PixelRGBA r g b a) = JP.PixelRGBA16 r g b a + +instance Convertible (Pixel YCbCr Word8) JP.PixelYCbCr8 where + convert (PixelYCbCr y cb cr) = JP.PixelYCbCr8 y cb cr + +instance Convertible (Pixel CMYK Word8) JP.PixelCMYK8 where + convert (PixelCMYK c m y k) = JP.PixelCMYK8 c m y k + +instance Convertible (Pixel CMYK Word16) JP.PixelCMYK16 where + convert (PixelCMYK c m y k) = JP.PixelCMYK16 c m y k + + + +-------------------------------------------------------------------------------- +-- Decoding images using JuicyPixels ------------------------------------------ +-------------------------------------------------------------------------------- + + +-- BMP Format Reading + +instance Readable (Image VS Binary Bit) BMP where + decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeBitmap + +instance Readable (Image VS Y Word8) BMP where + decode _ = jpImageY8ToImage . JP.decodeBitmap + +instance Readable (Image VS RGB Word8) BMP where + decode _ = jpImageRGB8ToImage . JP.decodeBitmap + +instance Readable (Image VS RGBA Word8) BMP where + decode _ = jpImageRGBA8ToImage . JP.decodeBitmap + + + +-- GIF Format Reading + +instance Readable (Image VS RGB Word8) GIF where + decode _ = jpImageRGB8ToImage . JP.decodeGif + +instance Readable (Image VS RGBA Word8) GIF where + decode _ = jpImageRGBA8ToImage . JP.decodeGif + + +-- Animated GIF Format frames reading into a list + +decodeGifs :: (Either String JP.DynamicImage -> Either String img) + -> B.ByteString -> Either String [img] +decodeGifs decoder bs = do + imgs <- JP.decodeGifImages bs + sequence $ fmap (decoder . Right) imgs + + +decodeGifsDelays :: (Either String JP.DynamicImage -> Either String img) + -> B.ByteString -> Either String [(GifDelay, img)] +decodeGifsDelays decoder bs = do + imgs <- JP.decodeGifImages bs + delays <- JP.getDelaysGifImages bs + gifs <- sequence $ fmap (decoder . Right) imgs + return $ zip delays gifs + + + +instance Readable [Image VS RGB Word8] GIFA where + decode _ = decodeGifs jpImageRGB8ToImage + +instance Readable [Image VS RGBA Word8] GIFA where + decode _ = decodeGifs jpImageRGBA8ToImage + +instance Readable [(GifDelay, Image VS RGB Word8)] GIFA where + decode _ = decodeGifsDelays jpImageRGB8ToImage + +instance Readable [(GifDelay, Image VS RGBA Word8)] GIFA where + decode _ = decodeGifsDelays jpImageRGBA8ToImage + + +-- HDR Format Reading + +instance Readable (Image VS RGB Float) HDR where + decode _ = jpImageRGBFToImage . JP.decodeHDR + + +-- JPG Format Reading + +instance Readable (Image VS Y Word8) JPG where + decode _ = jpImageY8ToImage . JP.decodeJpeg + +instance Readable (Image VS YA Word8) JPG where + decode _ = jpImageYA8ToImage . JP.decodeJpeg + +instance Readable (Image VS RGB Word8) JPG where + decode _ = jpImageRGB8ToImage . JP.decodeJpeg + +instance Readable (Image VS CMYK Word8) JPG where + decode _ = jpImageCMYK8ToImage . JP.decodeJpeg + +instance Readable (Image VS YCbCr Word8) JPG where + decode _ = jpImageYCbCr8ToImage . JP.decodeJpeg + + +-- PNG Format Reading + +instance Readable (Image VS Binary Bit) PNG where + decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodePng + +instance Readable (Image VS Y Word8) PNG where + decode _ = jpImageY8ToImage . JP.decodePng + +instance Readable (Image VS Y Word16) PNG where + decode _ = jpImageY16ToImage . JP.decodePng + +instance Readable (Image VS YA Word8) PNG where + decode _ = jpImageYA8ToImage . JP.decodePng + +instance Readable (Image VS YA Word16) PNG where + decode _ = jpImageYA16ToImage . JP.decodePng + +instance Readable (Image VS RGB Word8) PNG where + decode _ = jpImageRGB8ToImage . JP.decodePng + +instance Readable (Image VS RGB Word16) PNG where + decode _ = jpImageRGB16ToImage . JP.decodePng + +instance Readable (Image VS RGBA Word8) PNG where + decode _ = jpImageRGBA8ToImage . JP.decodePng + +instance Readable (Image VS RGBA Word16) PNG where + decode _ = jpImageRGBA16ToImage . JP.decodePng + + +-- TGA Format Reading + +instance Readable (Image VS Binary Bit) TGA where + decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTga + +instance Readable (Image VS Y Word8) TGA where + decode _ = jpImageY8ToImage . JP.decodeTga + +instance Readable (Image VS RGB Word8) TGA where + decode _ = jpImageRGB8ToImage . JP.decodeTga + +instance Readable (Image VS RGBA Word8) TGA where + decode _ = jpImageRGBA8ToImage . JP.decodeTga + + +-- TIF Format Reading + +instance Readable (Image VS Binary Bit) TIF where + decode _ = fmap toImageBinary . jpImageY8ToImage . JP.decodeTiff + +instance Readable (Image VS Y Word8) TIF where + decode _ = jpImageY8ToImage . JP.decodeTiff + +instance Readable (Image VS Y Word16) TIF where + decode _ = jpImageY16ToImage . JP.decodeTiff + +instance Readable (Image VS YA Word8) TIF where + decode _ = jpImageYA8ToImage . JP.decodeTiff + +instance Readable (Image VS YA Word16) TIF where + decode _ = jpImageYA16ToImage . JP.decodeTiff + +instance Readable (Image VS RGB Word8) TIF where + decode _ = jpImageRGB8ToImage . JP.decodeTiff + +instance Readable (Image VS RGB Word16) TIF where + decode _ = jpImageRGB16ToImage . JP.decodeTiff + +instance Readable (Image VS RGBA Word8) TIF where + decode _ = jpImageRGBA8ToImage . JP.decodeTiff + +instance Readable (Image VS RGBA Word16) TIF where + decode _ = jpImageRGBA16ToImage . JP.decodeTiff + +instance Readable (Image VS CMYK Word8) TIF where + decode _ = jpImageCMYK8ToImage . JP.decodeTiff + +instance Readable (Image VS CMYK Word16) TIF where + decode _ = jpImageCMYK16ToImage . JP.decodeTiff + + +-- To Double precision safe conversion + +instance Readable (Image VS Y Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Readable (Image VS YA Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Readable (Image VS RGB Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + +instance Readable (Image VS RGBA Double) BMP where + decode _ = jpDynamicImageToImage . JP.decodeBitmap + + +instance Readable (Image VS Y Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Readable (Image VS YA Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Readable (Image VS RGB Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + +instance Readable (Image VS RGBA Double) GIF where + decode _ = jpDynamicImageToImage . JP.decodeGif + + +instance Readable [Image VS Y Double] GIFA where + decode _ = decodeGifs jpDynamicImageToImage + +instance Readable [Image VS YA Double] GIFA where + decode _ = decodeGifs jpDynamicImageToImage + +instance Readable [Image VS RGB Double] GIFA where + decode _ = decodeGifs jpDynamicImageToImage + +instance Readable [Image VS RGBA Double] GIFA where + decode _ = decodeGifs jpDynamicImageToImage + + +instance Readable (Image VS Y Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Readable (Image VS YA Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Readable (Image VS RGB Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + +instance Readable (Image VS RGBA Double) HDR where + decode _ = jpDynamicImageToImage . JP.decodeHDR + + +instance Readable (Image VS Y Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Readable (Image VS YA Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Readable (Image VS RGB Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + +instance Readable (Image VS RGBA Double) JPG where + decode _ = jpDynamicImageToImage . JP.decodeJpeg + + +instance Readable (Image VS Y Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Readable (Image VS YA Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Readable (Image VS RGB Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + +instance Readable (Image VS RGBA Double) PNG where + decode _ = jpDynamicImageToImage . JP.decodePng + + +instance Readable (Image VS Y Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Readable (Image VS YA Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Readable (Image VS RGB Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + +instance Readable (Image VS RGBA Double) TGA where + decode _ = jpDynamicImageToImage . JP.decodeTga + + +instance Readable (Image VS Y Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Readable (Image VS YA Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Readable (Image VS RGB Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + +instance Readable (Image VS RGBA Double) TIF where + decode _ = jpDynamicImageToImage . JP.decodeTiff + + + +-- General decoding and helper functions + +jpImageToImageUnsafe :: (Array VS cs e, JP.Pixel jpx) => + JP.Image jpx -> Image VS cs e +jpImageToImageUnsafe (JP.Image n m !v) = fromVector (m, n) $ V.unsafeCast v + + + +-- jpImageToImageSafe :: (Array arr cs e, Convertible jpx (Pixel cs e), JP.Pixel jpx) => +-- JP.Image jpx -> Image arr cs e +-- jpImageToImageSafe !jimg = makeImage (JP.imageHeight jimg, JP.imageWidth jimg) getPx +-- where getPx !(y, x) = convert $ JP.pixelAt jimg x y + + +jpImageY8ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word8) +jpImageY8ToImage (Right (JP.ImageY8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageY8ToImage jimg = jpCSError "Y8 (Pixel Y Word8)" jimg + + +jpImageY16ToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Word16) +jpImageY16ToImage (Right (JP.ImageY16 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageY16ToImage jimg = jpCSError "Y16 (Pixel Y Word16)" jimg + +{- -- No JuicyPixels images are actually read in this type +jpImageYFToImage :: Either String JP.DynamicImage -> Either String (Image VS Y Float) +jpImageYFToImage (Right (JP.ImageYF jimg)) = Right (jpImageToImage jimg) +jpImageYFToImage jimg = jpCSError "YF (Pixel Y Float)" jimg +-} + +jpImageYA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word8) +jpImageYA8ToImage (Right (JP.ImageYA8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageYA8ToImage jimg = jpCSError "YA8 (Pixel YA Word8)" jimg + + +jpImageYA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS YA Word16) +jpImageYA16ToImage (Right (JP.ImageYA16 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageYA16ToImage jimg = jpCSError "YA16 (Pixel YA Word16)" jimg + + +jpImageRGB8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word8) +jpImageRGB8ToImage (Right (JP.ImageRGB8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageRGB8ToImage jimg = jpCSError "RGB8 (Pixel RGB Word8)" jimg + + +jpImageRGB16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Word16) +jpImageRGB16ToImage (Right (JP.ImageRGB16 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageRGB16ToImage jimg = jpCSError "RGB16 (Pixel RGB Word16)" jimg + + +jpImageRGBFToImage :: Either String JP.DynamicImage -> Either String (Image VS RGB Float) +jpImageRGBFToImage (Right (JP.ImageRGBF jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageRGBFToImage jimg = jpCSError "RGBF (Pixel RGB Float)" jimg + + +jpImageRGBA8ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word8) +jpImageRGBA8ToImage (Right (JP.ImageRGBA8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageRGBA8ToImage jimg = jpCSError "RGBA8 (Pixel RGBA Word8)" jimg + + +jpImageRGBA16ToImage :: Either String JP.DynamicImage -> Either String (Image VS RGBA Word16) +jpImageRGBA16ToImage (Right (JP.ImageRGBA16 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageRGBA16ToImage jimg = jpCSError "RGBA16 (Pixel RGBA Word16)" jimg + + +jpImageYCbCr8ToImage :: Either String JP.DynamicImage -> Either String (Image VS YCbCr Word8) +jpImageYCbCr8ToImage (Right (JP.ImageYCbCr8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageYCbCr8ToImage jimg = jpCSError "YCbCr8 (Pixel YCbCr Word8)" jimg + + +jpImageCMYK8ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word8) +jpImageCMYK8ToImage (Right (JP.ImageCMYK8 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageCMYK8ToImage jimg = jpCSError "CMYK8 (Pixel CMYK Word8)" jimg + + +jpImageCMYK16ToImage :: Either String JP.DynamicImage -> Either String (Image VS CMYK Word16) +jpImageCMYK16ToImage (Right (JP.ImageCMYK16 jimg)) = Right (jpImageToImageUnsafe jimg) +jpImageCMYK16ToImage jimg = jpCSError "CMYK16 (Pixel CMYK Word16)" jimg + + +jpDynamicImageToImage' :: (Convertible (Pixel Y Word8) (Pixel cs e), + Convertible (Pixel YA Word8) (Pixel cs e), + Convertible (Pixel Y Word16) (Pixel cs e), + Convertible (Pixel YA Word16) (Pixel cs e), + Convertible (Pixel Y Float) (Pixel cs e), + Convertible (Pixel RGB Word8) (Pixel cs e), + Convertible (Pixel RGBA Word8) (Pixel cs e), + Convertible (Pixel RGB Word16) (Pixel cs e), + Convertible (Pixel RGBA Word16) (Pixel cs e), + Convertible (Pixel RGB Float) (Pixel cs e), + Convertible (Pixel YCbCr Word8) (Pixel cs e), + Convertible (Pixel CMYK Word8) (Pixel cs e), + Convertible (Pixel CMYK Word16) (Pixel cs e), + Array VS cs e) => + JP.DynamicImage -> Image VS cs e +jpDynamicImageToImage' (JP.ImageY8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Word8) +jpDynamicImageToImage' (JP.ImageYA8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YA Word8) +jpDynamicImageToImage' (JP.ImageY16 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Word16) +jpDynamicImageToImage' (JP.ImageYA16 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YA Word16) +jpDynamicImageToImage' (JP.ImageYF jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS Y Float) +jpDynamicImageToImage' (JP.ImageRGB8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Word8) +jpDynamicImageToImage' (JP.ImageRGBA8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGBA Word8) +jpDynamicImageToImage' (JP.ImageRGB16 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Word16) +jpDynamicImageToImage' (JP.ImageRGBA16 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGBA Word16) +jpDynamicImageToImage' (JP.ImageRGBF jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS RGB Float) +jpDynamicImageToImage' (JP.ImageYCbCr8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS YCbCr Word8) +jpDynamicImageToImage' (JP.ImageCMYK8 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS CMYK Word8) +jpDynamicImageToImage' (JP.ImageCMYK16 jimg) = + I.map convert $ (jpImageToImageUnsafe jimg :: Image VS CMYK Word16) + + +jpDynamicImageToImage :: (Convertible (Pixel Y Word8) (Pixel cs e), + Convertible (Pixel YA Word8) (Pixel cs e), + Convertible (Pixel Y Word16) (Pixel cs e), + Convertible (Pixel YA Word16) (Pixel cs e), + Convertible (Pixel Y Float) (Pixel cs e), + Convertible (Pixel RGB Word8) (Pixel cs e), + Convertible (Pixel RGBA Word8) (Pixel cs e), + Convertible (Pixel RGB Word16) (Pixel cs e), + Convertible (Pixel RGBA Word16) (Pixel cs e), + Convertible (Pixel RGB Float) (Pixel cs e), + Convertible (Pixel YCbCr Word8) (Pixel cs e), + Convertible (Pixel CMYK Word8) (Pixel cs e), + Convertible (Pixel CMYK Word16) (Pixel cs e), + Array VS cs e) => + Either String JP.DynamicImage -> Either String (Image VS cs e) +jpDynamicImageToImage = either jpError (Right . jpDynamicImageToImage') + + +jpImageShowCS :: JP.DynamicImage -> String +jpImageShowCS (JP.ImageY8 _) = "Y8 (Pixel Y Word8)" +jpImageShowCS (JP.ImageY16 _) = "Y16 (Pixel Y Word16)" +jpImageShowCS (JP.ImageYF _) = "YF (Pixel Y Float)" +jpImageShowCS (JP.ImageYA8 _) = "YA8 (Pixel YA Word8)" +jpImageShowCS (JP.ImageYA16 _) = "YA16 (Pixel YA Word16)" +jpImageShowCS (JP.ImageRGB8 _) = "RGB8 (Pixel RGB Word8)" +jpImageShowCS (JP.ImageRGB16 _) = "RGB16 (Pixel RGB Word16)" +jpImageShowCS (JP.ImageRGBF _) = "RGBF (Pixel RGB Float)" +jpImageShowCS (JP.ImageRGBA8 _) = "RGBA8 (Pixel RGBA Word8)" +jpImageShowCS (JP.ImageRGBA16 _) = "RGBA16 (Pixel RGBA Word16)" +jpImageShowCS (JP.ImageYCbCr8 _) = "YCbCr8 (Pixel YCbCr Word8)" +jpImageShowCS (JP.ImageCMYK8 _) = "CMYK8 (Pixel CMYK Word8)" +jpImageShowCS (JP.ImageCMYK16 _) = "CMYK16 (Pixel CMYK Word16)" + + +jpError :: String -> Either String a +jpError err = Left ("JuicyPixel decoding error: "++err) + + +jpCSError :: String -> Either String JP.DynamicImage -> Either String a +jpCSError _ (Left err) = jpError err +jpCSError cs (Right jimg) = + jpError $ + "Input image is in " ++ + jpImageShowCS jimg ++ ", cannot convert it to " ++ cs ++ " colorspace." diff --git a/src/Graphics/Image/IO/Formats/JuicyPixels/Writable.hs b/src/Graphics/Image/IO/Formats/JuicyPixels/Writable.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/IO/Formats/JuicyPixels/Writable.hs @@ -0,0 +1,305 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | +-- Module : Graphics.Image.IO.Formats.JuicyPixels.Writable +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.IO.Formats.JuicyPixels.Writable () where + +import Prelude as P +import qualified Data.Monoid as M (mempty) +import Graphics.Image.ColorSpace +import Graphics.Image.Interface as I +import Graphics.Image.Interface.Vector +import Graphics.Image.IO.Base +import Graphics.Image.IO.Formats.JuicyPixels.Common +import qualified Data.ByteString.Lazy as BL (ByteString) +import qualified Codec.Picture as JP +import qualified Codec.Picture.Jpg as JP +import qualified Codec.Picture.ColorQuant as JP +import qualified Data.Vector.Storable as V + +-------------------------------------------------------------------------------- +-- Encoding images using JuicyPixels ------------------------------------------- +-------------------------------------------------------------------------------- + +instance Writable (Image VS Y Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) id + +instance Writable (Image VS RGB Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) id + +instance Writable (Image VS RGBA Word8) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) id + +instance Writable (Image VS Binary Bit) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary + +instance Writable (Image VS Y Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) + +instance Writable (Image VS YA Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.Pixel8) + ((fmap toWord8) . dropAlpha) + +instance Writable (Image VS RGB Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) + +instance Writable (Image VS RGBA Double) BMP where + encode _ _ = JP.encodeBitmap . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8) + +-- Writable GIF + +encodeGIF :: (Array VS cs' e, Array VS cs Word8) => + [SaveOption GIF] -> (Pixel cs' e -> Pixel cs Word8) + -> Image VS cs' e -> BL.ByteString +encodeGIF [] !conv = + either error id . uncurry JP.encodeGifImageWithPalette . + JP.palettize JP.defaultPaletteOptions . imageToJPImage (undefined :: JP.PixelRGB8) conv +encodeGIF (GIFPalette palOpts:_) !conv = + either error id . uncurry JP.encodeGifImageWithPalette . + JP.palettize palOpts . imageToJPImage (undefined :: JP.PixelRGB8) conv + + +instance Writable (Image VS RGB Word8) GIF where + encode _ opts = encodeGIF opts id + +instance Writable (Image VS Y Double) GIF where + encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB) + +instance Writable (Image VS YA Double) GIF where + encode _ opts = encodeGIF opts ((fmap toWord8) . toPixelRGB . dropAlpha) + +instance Writable (Image VS RGB Double) GIF where + encode _ opts = encodeGIF opts (fmap toWord8) + +instance Writable (Image VS RGBA Double) GIF where + encode _ opts = encodeGIF opts ((fmap toWord8) . dropAlpha) + + +encodeGIFA :: (Array VS cs' e, Array VS cs Word8) => + [SaveOption GIFA] -> (Pixel cs' e -> Pixel cs Word8) + -> [(JP.GifDelay, Image VS cs' e)] -> BL.ByteString +encodeGIFA !opts !conv = + either error id . JP.encodeGifImages (getGIFALoop opts) . P.map palletizeGif where + getGIFALoop [] = JP.LoopingNever + getGIFALoop (GIFALooping loop:_) = loop + getGIFALoop (_:xs) = getGIFALoop xs + getGIFAPal [] = JP.defaultPaletteOptions + getGIFAPal (GIFAPalette palOpts:_) = palOpts + getGIFAPal (_:xs) = getGIFAPal xs + palletizeGif !(d, img) = (p, d, jimg) where + !(jimg, p) = JP.palettize (getGIFAPal opts) $ + imageToJPImage (undefined :: JP.PixelRGB8) conv img + + +instance Writable [(JP.GifDelay, Image VS RGB Word8)] GIFA where + encode _ opts = encodeGIFA opts id + +instance Writable [(JP.GifDelay, Image VS RGB Double)] GIFA where + encode _ opts = encodeGIFA opts (fmap toWord8) + +-- Writable HDR + +instance Writable (Image VS RGB Float) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) id + +instance Writable (Image VS Y Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) + (fmap toFloat . toPixelRGB) + +instance Writable (Image VS YA Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) + (fmap toFloat . toPixelRGB . dropAlpha) + +instance Writable (Image VS RGB Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) (fmap toFloat) + +instance Writable (Image VS RGBA Double) HDR where + encode _ _ = JP.encodeHDR . imageToJPImage (undefined :: JP.PixelRGBF) + (fmap toFloat . dropAlpha) + + +-- Writable JPG + + +encodeJPG + :: (JP.JpgEncodable px, Array VS cs' e, Array VS cs (JP.PixelBaseComponent px)) => + [SaveOption JPG] + -> px + -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent px)) + -> Image VS cs' e + -> BL.ByteString +encodeJPG [] t conv = + JP.encodeDirectJpegAtQualityWithMetadata 100 M.mempty . imageToJPImage t conv +encodeJPG (JPGQuality q:_) t conv = + JP.encodeDirectJpegAtQualityWithMetadata q M.mempty . imageToJPImage t conv + + +instance Writable (Image VS Y Word8) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) id + +instance Writable (Image VS RGB Word8) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) id + +instance Writable (Image VS CMYK Word8) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.PixelCMYK8) id + +instance Writable (Image VS YCbCr Word8) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.PixelYCbCr8) id + +instance Writable (Image VS Y Double) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) (fmap toWord8) + +instance Writable (Image VS YA Double) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) + +instance Writable (Image VS RGB Double) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) (fmap toWord8) + +instance Writable (Image VS RGBA Double) JPG where + encode _ opts = encodeJPG opts (undefined :: JP.PixelRGB8) ((fmap toWord8) . dropAlpha) + + +-- Writable PNG + +instance Writable (Image VS Binary Bit) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary + +instance Writable (Image VS Y Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel8) id + +instance Writable (Image VS Y Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) id + +instance Writable (Image VS YA Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA8) id + +instance Writable (Image VS YA Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) id + +instance Writable (Image VS RGB Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB8) id + +instance Writable (Image VS RGB Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) id + +instance Writable (Image VS RGBA Word8) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA8) id + +instance Writable (Image VS RGBA Word16) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) id + + +instance Writable (Image VS Y Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) + +instance Writable (Image VS YA Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) + +instance Writable (Image VS RGB Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) + +instance Writable (Image VS RGBA Double) PNG where + encode _ _ = JP.encodePng . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16) + +-- Writable TGA + +instance Writable (Image VS Binary Bit) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary + +instance Writable (Image VS Y Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) id + +instance Writable (Image VS RGB Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) id + +instance Writable (Image VS RGBA Word8) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) id + + +instance Writable (Image VS Y Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) (fmap toWord8) + +instance Writable (Image VS YA Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.Pixel8) ((fmap toWord8) . dropAlpha) + +instance Writable (Image VS RGB Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGB8) (fmap toWord8) + +instance Writable (Image VS RGBA Double) TGA where + encode _ _ = JP.encodeTga . imageToJPImage (undefined :: JP.PixelRGBA8) (fmap toWord8) + +-- Writable TIF + +instance Writable (Image VS Y Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) id + +instance Writable (Image VS Y Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) id + +instance Writable (Image VS YA Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA8) id + +instance Writable (Image VS YA Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) id + +instance Writable (Image VS RGB Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB8) id + +instance Writable (Image VS RGB Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) id + +instance Writable (Image VS RGBA Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA8) id + +instance Writable (Image VS RGBA Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) id + +instance Writable (Image VS YCbCr Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) id + +instance Writable (Image VS CMYK Word8) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK8) id + +instance Writable (Image VS CMYK Word16) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) id + + +instance Writable (Image VS Binary Bit) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel8) fromPixelBinary + +instance Writable (Image VS Y Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.Pixel16) (fmap toWord16) + +instance Writable (Image VS YA Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYA16) (fmap toWord16) + +instance Writable (Image VS RGB Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGB16) (fmap toWord16) + +instance Writable (Image VS RGBA Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelRGBA16) (fmap toWord16) + +instance Writable (Image VS YCbCr Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelYCbCr8) (fmap toWord8) + +instance Writable (Image VS CMYK Double) TIF where + encode _ _ = JP.encodeTiff . imageToJPImage (undefined :: JP.PixelCMYK16) (fmap toWord16) + + + +imageToJPImage :: (JP.Pixel a, Array VS cs' e, Array VS cs (JP.PixelBaseComponent a)) => + a -> (Pixel cs' e -> Pixel cs (JP.PixelBaseComponent a)) -> Image VS cs' e -> JP.Image a +imageToJPImage _ f !img = JP.Image n m $ V.unsafeCast $ toVector $ I.map f img where + !(m, n) = dims img diff --git a/src/Graphics/Image/IO/Formats/Netpbm.hs b/src/Graphics/Image/IO/Formats/Netpbm.hs --- a/src/Graphics/Image/IO/Formats/Netpbm.hs +++ b/src/Graphics/Image/IO/Formats/Netpbm.hs @@ -15,9 +15,8 @@ PBM(..), PGM(..), PPM(..) ) where - import Graphics.Image.ColorSpace -import Graphics.Image.Interface hiding (map) +import Graphics.Image.Interface as I import Graphics.Image.Interface.Vector import Graphics.Image.IO.Base import Foreign.Storable (Storable) @@ -75,76 +74,7 @@ -- Converting to and from Netpbm ----------------------------------------------- -------------------------------------------------------------------------------- --- -> Y (Double) -instance Convertible PNM.PbmPixel (Pixel Y Double) where - convert (PNM.PbmPixel bool) = PixelY $ if bool then 0 else 1 - -instance Convertible PNM.PgmPixel8 (Pixel Y Double) where - convert (PNM.PgmPixel8 w8) = PixelY $ toDouble w8 - -instance Convertible PNM.PgmPixel16 (Pixel Y Double) where - convert (PNM.PgmPixel16 w16) = PixelY $ toDouble w16 - -instance Convertible PNM.PpmPixelRGB8 (Pixel Y Double) where - convert (PNM.PpmPixelRGB8 r g b) = toPixelY . fmap toDouble $ PixelRGB r g b - -instance Convertible PNM.PpmPixelRGB16 (Pixel Y Double) where - convert (PNM.PpmPixelRGB16 r g b) = toPixelY . fmap toDouble $ PixelRGB r g b - --- -> YA (Double) - -instance Convertible PNM.PbmPixel (Pixel YA Double) where - convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel Y Double) - -instance Convertible PNM.PgmPixel8 (Pixel YA Double) where - convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel Y Double) - -instance Convertible PNM.PgmPixel16 (Pixel YA Double) where - convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel Y Double) - -instance Convertible PNM.PpmPixelRGB8 (Pixel YA Double) where - convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel Y Double) - -instance Convertible PNM.PpmPixelRGB16 (Pixel YA Double) where - convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel Y Double) - --- -> RGB (Double) - -instance Convertible PNM.PbmPixel (Pixel RGB Double) where - convert = toPixelRGB . (convert :: PNM.PbmPixel -> Pixel Y Double) - -instance Convertible PNM.PgmPixel8 (Pixel RGB Double) where - convert = toPixelRGB . (convert :: PNM.PgmPixel8 -> Pixel Y Double) - -instance Convertible PNM.PgmPixel16 (Pixel RGB Double) where - convert = toPixelRGB . (convert :: PNM.PgmPixel16 -> Pixel Y Double) - -instance Convertible PNM.PpmPixelRGB8 (Pixel RGB Double) where - convert (PNM.PpmPixelRGB8 r g b) = fmap toDouble $ PixelRGB r g b - -instance Convertible PNM.PpmPixelRGB16 (Pixel RGB Double) where - convert (PNM.PpmPixelRGB16 r g b) = fmap toDouble $ PixelRGB r g b - - --- -> RGBA (Double) - -instance Convertible PNM.PbmPixel (Pixel RGBA Double) where - convert = addAlpha 1 . (convert :: PNM.PbmPixel -> Pixel RGB Double) - -instance Convertible PNM.PgmPixel8 (Pixel RGBA Double) where - convert = addAlpha 1 . (convert :: PNM.PgmPixel8 -> Pixel RGB Double) - -instance Convertible PNM.PgmPixel16 (Pixel RGBA Double) where - convert = addAlpha 1 . (convert :: PNM.PgmPixel16 -> Pixel RGB Double) - -instance Convertible PNM.PpmPixelRGB8 (Pixel RGBA Double) where - convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB8 -> Pixel RGB Double) - -instance Convertible PNM.PpmPixelRGB16 (Pixel RGBA Double) where - convert = addAlpha 1 . (convert :: PNM.PpmPixelRGB16 -> Pixel RGB Double) - - ---- Exact precision conversions @@ -169,27 +99,27 @@ -------------------------------------------------------------------------------- --- BMP Format Reading (general) +-- BPM Format Reading (general) -instance Array arr Y Double => Readable (Image arr Y Double) PBM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm +instance Readable (Image VS Y Double) PBM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm -instance Array arr Y Double => Readable (Image arr Y Double) PGM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm +instance Readable (Image VS Y Double) PGM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm -instance Array arr Y Double => Readable (Image arr Y Double) PPM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm +instance Readable (Image VS Y Double) PPM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm -instance Array arr YA Double => Readable (Image arr YA Double) PPM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm +instance Readable (Image VS YA Double) PPM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm -instance Array arr RGB Double => Readable (Image arr RGB Double) PPM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage id) . head) . decodePnm +instance Readable (Image VS RGB Double) PPM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm -instance Array arr RGBA Double => Readable (Image arr RGBA Double) PPM where - decode _ = fmap (ppmToImageUsing (pnmDataToImage (addAlpha 1)) . head) . decodePnm +instance Readable (Image VS RGBA Double) PPM where + decode _ = fmap (ppmToImageUsing pnmDataToImage . head) . decodePnm --- BMP Format Reading (exact) +-- BPM Format Reading (exact) instance Readable (Image VS Binary Bit) PBM where decode _ = either Left (ppmToImageUsing pnmDataPBMToImage . head) . decodePnm @@ -226,22 +156,26 @@ pnmToImagesUsing :: (Int -> Int -> PNM.PpmPixelData -> Either String b) -> B.ByteString -> Either String [b] pnmToImagesUsing conv = - fmap (map (either error id . ppmToImageUsing conv)) . decodePnm - - -getPx :: (Storable a, Convertible a b) => V.Vector a -> Int -> (Int, Int) -> b -getPx v w (i, j) = convert (v V.! (i * w + j)) + fmap (fmap (either error id . ppmToImageUsing conv)) . decodePnm -pnmDataToImage :: (Array arr cs e, Convertible PNM.PbmPixel px, - Convertible PNM.PgmPixel16 px, Convertible PNM.PgmPixel8 px, - Convertible PNM.PpmPixelRGB16 px, Convertible PNM.PpmPixelRGB8 px) => - (px -> Pixel cs e) -> Int -> Int -> PNM.PpmPixelData -> Image arr cs e -pnmDataToImage conv w h (PNM.PbmPixelData v) = makeImage (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PgmPixelData8 v) = makeImage (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PgmPixelData16 v) = makeImage (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PpmPixelDataRGB8 v) = makeImage (h, w) (conv . getPx v w) -pnmDataToImage conv w h (PNM.PpmPixelDataRGB16 v) = makeImage (h, w) (conv . getPx v w) +pnmDataToImage :: (Convertible (Pixel Binary Bit) (Pixel cs e), + Convertible (Pixel Y Word8) (Pixel cs e), + Convertible (Pixel Y Word16) (Pixel cs e), + Convertible (Pixel RGB Word8) (Pixel cs e), + Convertible (Pixel RGB Word16) (Pixel cs e), + Array VS cs e) => + Int -> Int -> PNM.PpmPixelData -> Image VS cs e +pnmDataToImage w h (PNM.PbmPixelData v) = + I.map convert (makeImageUnsafe (h, w) v :: Image VS Binary Bit) +pnmDataToImage w h (PNM.PgmPixelData8 v) = + I.map convert (makeImageUnsafe (h, w) v :: Image VS Y Word8) +pnmDataToImage w h (PNM.PgmPixelData16 v) = + I.map convert (makeImageUnsafe (h, w) v :: Image VS Y Word16) +pnmDataToImage w h (PNM.PpmPixelDataRGB8 v) = + I.map convert (makeImageUnsafe (h, w) v :: Image VS RGB Word8) +pnmDataToImage w h (PNM.PpmPixelDataRGB16 v) = + I.map convert (makeImageUnsafe (h, w) v :: Image VS RGB Word16) makeImageUnsafe diff --git a/src/Graphics/Image/Interface.hs b/src/Graphics/Image/Interface.hs --- a/src/Graphics/Image/Interface.hs +++ b/src/Graphics/Image/Interface.hs @@ -42,16 +42,16 @@ import GHC.Exts (Constraint) import Data.Typeable (Typeable, showsTypeRep, typeOf) import Control.DeepSeq (NFData(rnf), deepseq) -import Data.Word import qualified Data.Vector.Generic as VG import qualified Data.Vector.Unboxed as VU +import Graphics.Image.Interface.Elevator -- | A Pixel family with a color space and a precision of elements. data family Pixel cs e :: * -class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e, Typeable e, +class (Eq cs, Enum cs, Show cs, Bounded cs, Typeable cs, Elevator e, Eq (Pixel cs e), VU.Unbox (Components cs e)) => ColorSpace cs e where @@ -115,7 +115,7 @@ -- | Get an alpha channel of a transparant pixel. getAlpha :: Pixel cs e -> e - -- | Add an alpha channel of an opaque pixel. + -- | Add an alpha channel to an opaque pixel. -- -- @ addAlpha 0 (PixelHSI 1 2 3) == PixelHSIA 1 2 3 0 @ addAlpha :: e -> Pixel (Opaque cs) e -> Pixel cs e @@ -128,39 +128,8 @@ dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e --- | A class with a set of convenient functions that allow for changing precision of --- channels within pixels, while scaling the values to keep them in an appropriate range. --- --- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double --- >>> toWord8 rgb --- --- -class (Eq e, Num e, VU.Unbox e) => Elevator e where - - -- | Values are scaled to @[0, 255]@ range. - toWord8 :: e -> Word8 - - -- | Values are scaled to @[0, 65535]@ range. - toWord16 :: e -> Word16 - - -- | Values are scaled to @[0, 4294967295]@ range. - toWord32 :: e -> Word32 - - -- | Values are scaled to @[0, 18446744073709551615]@ range. - toWord64 :: e -> Word64 - - -- | Values are scaled to @[0.0, 1.0]@ range. - toFloat :: e -> Float - - -- | Values are scaled to @[0.0, 1.0]@ range. - toDouble :: e -> Double - - -- | Values are scaled from @[0.0, 1.0]@ range. - fromDouble :: Double -> e - - -- | Base array like representation for an image. -class (Show arr, ColorSpace cs e, SuperClass arr cs e) => +class (Typeable arr, ColorSpace cs e, SuperClass arr cs e) => BaseArray arr cs e where -- | Required array specific constraints for an array element. @@ -337,7 +306,7 @@ -- | Array representation that is actually has real data stored in memory, hence -- allowing for image indexing, forcing pixels into computed state etc. -class (BaseArray arr cs e) => MArray arr cs e where +class BaseArray arr cs e => MArray arr cs e where data MImage s arr cs e unsafeIndex :: Image arr cs e -> (Int, Int) -> Pixel cs e @@ -705,8 +674,7 @@ Show (Image arr cs e) where show (dims -> (m, n)) = "" @@ -716,8 +684,7 @@ Show (MImage st arr cs e) where show (mdims -> (m, n)) = "" diff --git a/src/Graphics/Image/Interface/Elevator.hs b/src/Graphics/Image/Interface/Elevator.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/Image/Interface/Elevator.hs @@ -0,0 +1,317 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +#if __GLASGOW_HASKELL__ >= 800 + {-# OPTIONS_GHC -Wno-redundant-constraints #-} +#endif +-- | +-- Module : Graphics.Image.Interface.Elevator +-- Copyright : (c) Alexey Kuleshevich 2017 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +module Graphics.Image.Interface.Elevator ( + Elevator(..) + ) where + +import qualified Data.Complex as C +import Data.Int +import Data.Word +import GHC.Float +import Data.Typeable +import Data.Vector.Unboxed (Unbox) + + +-- | A class with a set of convenient functions that allow for changing precision of +-- channels within pixels, while scaling the values to keep them in an appropriate range. +-- +-- >>> let rgb = PixelRGB 0.0 0.5 1.0 :: Pixel RGB Double +-- >>> toWord8 <$> rgb +-- +-- >>> toWord16 <$> rgb +-- +-- +class (Eq e, Num e, Typeable e, Unbox e) => Elevator e where + + -- | Values are scaled to @[0, 255]@ range. + toWord8 :: e -> Word8 + + -- | Values are scaled to @[0, 65535]@ range. + toWord16 :: e -> Word16 + + -- | Values are scaled to @[0, 4294967295]@ range. + toWord32 :: e -> Word32 + + -- | Values are scaled to @[0, 18446744073709551615]@ range. + toWord64 :: e -> Word64 + + -- | Values are scaled to @[0.0, 1.0]@ range. + toFloat :: e -> Float + + -- | Values are scaled to @[0.0, 1.0]@ range. + toDouble :: e -> Double + + -- | Values are scaled from @[0.0, 1.0]@ range. + fromDouble :: Double -> e + + +-- | Lower the precision +dropDown :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b +dropDown !e = fromIntegral $ fromIntegral e `div` ((maxBound :: a) `div` + fromIntegral (maxBound :: b)) +{-# INLINE dropDown #-} + +-- | Increase the precision +raiseUp :: forall a b. (Integral a, Bounded a, Integral b, Bounded b) => a -> b +raiseUp !e = fromIntegral e * ((maxBound :: b) `div` fromIntegral (maxBound :: a)) +{-# INLINE raiseUp #-} + +-- | Convert to fractional with value less than or equal to 1. +squashTo1 :: forall a b. (Fractional b, Integral a, Bounded a) => a -> b +squashTo1 !e = fromIntegral e / fromIntegral (maxBound :: a) +{-# INLINE squashTo1 #-} + +-- | Convert to integral streaching it's value up to a maximum value. +stretch :: forall a b. (RealFrac a, Floating a, Integral b, Bounded b) => a -> b +stretch !e = round (fromIntegral (maxBound :: b) * clamp01 e) + + +-- | Clamp a value to @[0, 1]@ range. +clamp01 :: (Ord a, Floating a) => a -> a +clamp01 !x = min (max 0 x) 1 +{-# INLINE clamp01 #-} + + +-- | Values between @[0, 255]]@ +instance Elevator Word8 where + toWord8 = id + {-# INLINE toWord8 #-} + toWord16 = raiseUp + {-# INLINE toWord16 #-} + toWord32 = raiseUp + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord8 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 65535]]@ +instance Elevator Word16 where + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = id + {-# INLINE toWord16 #-} + toWord32 = raiseUp + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord16 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 4294967295]@ +instance Elevator Word32 where + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = id + {-# INLINE toWord32 #-} + toWord64 = raiseUp + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord32 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 18446744073709551615]@ +instance Elevator Word64 where + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = dropDown + {-# INLINE toWord32 #-} + toWord64 = id + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = toWord64 + {-# INLINE fromDouble #-} + +-- | Values between @[0, 18446744073709551615]@ on 64bit +instance Elevator Word where + toWord8 = dropDown + {-# INLINE toWord8 #-} + toWord16 = dropDown + {-# INLINE toWord16 #-} + toWord32 = dropDown + {-# INLINE toWord32 #-} + toWord64 = fromIntegral + {-# INLINE toWord64 #-} + toFloat = squashTo1 + {-# INLINE toFloat #-} + toDouble = squashTo1 + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + +-- | Values between @[0, 127]@ +instance Elevator Int8 where + toWord8 = fromIntegral . (max 0) + {-# INLINE toWord8 #-} + toWord16 = raiseUp . (max 0) + {-# INLINE toWord16 #-} + toWord32 = raiseUp . (max 0) + {-# INLINE toWord32 #-} + toWord64 = raiseUp . (max 0) + {-# INLINE toWord64 #-} + toFloat = squashTo1 . (max 0) + {-# INLINE toFloat #-} + toDouble = squashTo1 . (max 0) + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 32767]@ +instance Elevator Int16 where + toWord8 = dropDown . (max 0) + {-# INLINE toWord8 #-} + toWord16 = fromIntegral . (max 0) + {-# INLINE toWord16 #-} + toWord32 = raiseUp . (max 0) + {-# INLINE toWord32 #-} + toWord64 = raiseUp . (max 0) + {-# INLINE toWord64 #-} + toFloat = squashTo1 . (max 0) + {-# INLINE toFloat #-} + toDouble = squashTo1 . (max 0) + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 2147483647]@ +instance Elevator Int32 where + toWord8 = dropDown . (max 0) + {-# INLINE toWord8 #-} + toWord16 = dropDown . (max 0) + {-# INLINE toWord16 #-} + toWord32 = fromIntegral . (max 0) + {-# INLINE toWord32 #-} + toWord64 = raiseUp . (max 0) + {-# INLINE toWord64 #-} + toFloat = squashTo1 . (max 0) + {-# INLINE toFloat #-} + toDouble = squashTo1 . (max 0) + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 9223372036854775807]@ +instance Elevator Int64 where + toWord8 = dropDown . (max 0) + {-# INLINE toWord8 #-} + toWord16 = dropDown . (max 0) + {-# INLINE toWord16 #-} + toWord32 = dropDown . (max 0) + {-# INLINE toWord32 #-} + toWord64 = fromIntegral . (max 0) + {-# INLINE toWord64 #-} + toFloat = squashTo1 . (max 0) + {-# INLINE toFloat #-} + toDouble = squashTo1 . (max 0) + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + + +-- | Values between @[0, 9223372036854775807]@ on 64bit +instance Elevator Int where + toWord8 = dropDown . (max 0) + {-# INLINE toWord8 #-} + toWord16 = dropDown . (max 0) + {-# INLINE toWord16 #-} + toWord32 = dropDown . (max 0) + {-# INLINE toWord32 #-} + toWord64 = fromIntegral . (max 0) + {-# INLINE toWord64 #-} + toFloat = squashTo1 . (max 0) + {-# INLINE toFloat #-} + toDouble = squashTo1 . (max 0) + {-# INLINE toDouble #-} + fromDouble = stretch . clamp01 + {-# INLINE fromDouble #-} + + +-- | Values between @[0.0, 1.0]@ +instance Elevator Float where + toWord8 = stretch . clamp01 + {-# INLINE toWord8 #-} + toWord16 = stretch . clamp01 + {-# INLINE toWord16 #-} + toWord32 = stretch . clamp01 + {-# INLINE toWord32 #-} + toWord64 = stretch . clamp01 + {-# INLINE toWord64 #-} + toFloat = id + {-# INLINE toFloat #-} + toDouble = float2Double + {-# INLINE toDouble #-} + fromDouble = toFloat + {-# INLINE fromDouble #-} + + +-- | Values between @[0.0, 1.0]@ +instance Elevator Double where + toWord8 = stretch . clamp01 + {-# INLINE toWord8 #-} + toWord16 = stretch . clamp01 + {-# INLINE toWord16 #-} + toWord32 = stretch . clamp01 + {-# INLINE toWord32 #-} + toWord64 = stretch . clamp01 + {-# INLINE toWord64 #-} + toFloat = double2Float + {-# INLINE toFloat #-} + toDouble = id + {-# INLINE toDouble #-} + fromDouble = id + {-# INLINE fromDouble #-} + + +-- | Discards imaginary part and changes precision of real part. +instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where + toWord8 = toWord8 . C.realPart + {-# INLINE toWord8 #-} + toWord16 = toWord16 . C.realPart + {-# INLINE toWord16 #-} + toWord32 = toWord32 . C.realPart + {-# INLINE toWord32 #-} + toWord64 = toWord64 . C.realPart + {-# INLINE toWord64 #-} + toFloat = toFloat . C.realPart + {-# INLINE toFloat #-} + toDouble = toDouble . C.realPart + {-# INLINE toDouble #-} + fromDouble = (C.:+ 0) . fromDouble + {-# INLINE fromDouble #-} diff --git a/src/Graphics/Image/Interface/Repa/Generic.hs b/src/Graphics/Image/Interface/Repa/Generic.hs --- a/src/Graphics/Image/Interface/Repa/Generic.hs +++ b/src/Graphics/Image/Interface/Repa/Generic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -27,6 +28,7 @@ import qualified Data.Array.Repa as R import qualified Data.Array.Repa.Eval as R import qualified Data.Vector.Generic as VG +import Data.Typeable (Typeable) import Graphics.Image.ColorSpace.Binary (Bit(..)) import Graphics.Image.Interface as I @@ -38,10 +40,10 @@ -- | Repa Array representation, which is computed in parallel. -data RP r = RP r +data RP r = RP r deriving Typeable -- | Repa Array representation, which is computed sequentially. -data RS r = RS r +data RS r = RS r deriving Typeable instance Show r => Show (RP r) where show (RP r) = "RepaParallel " ++ show r @@ -56,7 +58,7 @@ instance SuperClass (RS r) cs e => BaseArray (RS r) cs e where type SuperClass (RS r) cs e = - (Show r, ColorSpace cs e, R.Elt (Pixel cs e), R.Elt e, + (Typeable r, ColorSpace cs e, R.Elt (Pixel cs e), R.Elt e, R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e), BaseArray r cs e) @@ -184,7 +186,7 @@ instance SuperClass (RP r) cs e => BaseArray (RP r) cs e where type SuperClass (RP r) cs e = ( - Show r, ColorSpace cs e, + Typeable r, ColorSpace cs e, R.Target (Repr r) (Pixel cs e), R.Source (Repr r) (Pixel cs e), BaseArray r cs e, R.Elt e, R.Elt (Pixel cs e)) diff --git a/src/Graphics/Image/Interface/Repa/Storable.hs b/src/Graphics/Image/Interface/Repa/Storable.hs --- a/src/Graphics/Image/Interface/Repa/Storable.hs +++ b/src/Graphics/Image/Interface/Repa/Storable.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -26,6 +27,7 @@ import qualified Data.Array.Repa.Repr.ForeignPtr as R import qualified Data.Vector.Storable as VS import Foreign.Storable +import Data.Typeable (Typeable) import Graphics.Image.Interface as I import Graphics.Image.Interface.Repa.Generic @@ -35,16 +37,16 @@ -- | Repa Array representation backed by Storable Vector, which is computed sequentially. -data RSS = RSS +data RSS = RSS deriving Typeable -- | Repa Array representation backed by Storable Vector, which is computed in parallel. -data RPS = RPS +data RPS = RPS deriving Typeable instance Show RSS where - show RSS = "RepaSequentialStorable" + show _ = "RepaSequentialStorable" instance Show RPS where - show RPS = "RepaParallelStorable" + show _ = "RepaParallelStorable" type instance Repr IVS.VS = R.F diff --git a/src/Graphics/Image/Interface/Repa/Unboxed.hs b/src/Graphics/Image/Interface/Repa/Unboxed.hs --- a/src/Graphics/Image/Interface/Repa/Unboxed.hs +++ b/src/Graphics/Image/Interface/Repa/Unboxed.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -22,6 +23,7 @@ import Prelude as P import qualified Data.Array.Repa as R import qualified Data.Array.Repa.Eval as R +import Data.Typeable (Typeable) import Graphics.Image.Interface as I import Graphics.Image.Interface.Repa.Generic @@ -29,16 +31,16 @@ -- | Repa Array representation backed by Unboxed Vector, which is computed sequentially. -data RSU = RSU +data RSU = RSU deriving Typeable -- | Repa Array representation backed by Unboxed Vector, which is computed in parallel. -data RPU = RPU +data RPU = RPU deriving Typeable instance Show RSU where - show RSU = "RepaSequentialUnboxed" + show _ = "RepaSequentialUnboxed" instance Show RPU where - show RPU = "RepaParallelUnboxed" + show _ = "RepaParallelUnboxed" type instance Repr IVU.VU = R.U diff --git a/src/Graphics/Image/Interface/Vector/Generic.hs b/src/Graphics/Image/Interface/Vector/Generic.hs --- a/src/Graphics/Image/Interface/Vector/Generic.hs +++ b/src/Graphics/Image/Interface/Vector/Generic.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -30,13 +31,14 @@ import Data.Functor #endif import Data.Primitive.MutVar +import Data.Typeable (Typeable) import qualified Data.Vector.Unboxed as VU import qualified Data.Vector.Generic as VG import qualified Data.Vector.Generic.Mutable as MVG import Graphics.Image.Interface as I -- | Generic 'Vector' representation. -data G r = G r +data G r = G r deriving Typeable instance Show r => Show (G r) where @@ -44,7 +46,7 @@ instance SuperClass (G r) cs e => BaseArray (G r) cs e where type SuperClass (G r) cs e = - (Show r, ColorSpace cs e, + (Typeable r, ColorSpace cs e, VG.Vector (Vector r) Int, VG.Vector (Vector r) Bool, VG.Vector (Vector r) (Pixel cs e), NFData ((Vector r) (Pixel cs e))) @@ -216,7 +218,7 @@ unsafeIndex (VScalar px) _ = px {-# INLINE unsafeIndex #-} - deepSeqImage (VImage m n v) = m `seq` n `seq` deepseq v + deepSeqImage (VImage _ _ v) = deepseq v deepSeqImage (VScalar px) = seq px {-# INLINE deepSeqImage #-} diff --git a/src/Graphics/Image/Interface/Vector/Storable.hs b/src/Graphics/Image/Interface/Vector/Storable.hs --- a/src/Graphics/Image/Interface/Vector/Storable.hs +++ b/src/Graphics/Image/Interface/Vector/Storable.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,6 +26,7 @@ #if !MIN_VERSION_base(4,8,0) import Data.Functor #endif +import Data.Typeable (Typeable) import qualified Data.Vector.Storable as VS import Graphics.Image.Interface as I import Graphics.Image.Interface.Vector.Generic @@ -32,7 +34,7 @@ -- | Storable 'Vector' representation. -data VS = VS +data VS = VS deriving Typeable instance Show VS where show _ = "VectorStorable" diff --git a/src/Graphics/Image/Interface/Vector/Unboxed.hs b/src/Graphics/Image/Interface/Vector/Unboxed.hs --- a/src/Graphics/Image/Interface/Vector/Unboxed.hs +++ b/src/Graphics/Image/Interface/Vector/Unboxed.hs @@ -1,6 +1,7 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,6 +26,7 @@ #if !MIN_VERSION_base(4,8,0) import Data.Functor #endif +import Data.Typeable (Typeable) import qualified Data.Vector.Unboxed as VU import Graphics.Image.Interface as I import Graphics.Image.Interface.Vector.Generic @@ -33,7 +35,7 @@ -- | Unboxed 'Vector' representation. -data VU = VU +data VU = VU deriving Typeable instance Show VU where show _ = "VectorUnboxed" diff --git a/src/Graphics/Image/Processing/Convolution.hs b/src/Graphics/Image/Processing/Convolution.hs --- a/src/Graphics/Image/Processing/Convolution.hs +++ b/src/Graphics/Image/Processing/Convolution.hs @@ -21,9 +21,9 @@ --- | Correlate an image using a kernel. Border resolution technique is required. -correlate :: I.Array arr cs e => - Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e +-- | Correlate an image with a kernel. Border resolution technique is required. +correlate :: Array arr cs e => + Border (Pixel cs e) -> Image arr cs e -> Image arr cs e -> Image arr cs e correlate !border !kernel !img = I.traverse (compute img) (const sz) stencil where diff --git a/tests/Graphics/Image/ColorSpaceSpec.hs b/tests/Graphics/Image/ColorSpaceSpec.hs --- a/tests/Graphics/Image/ColorSpaceSpec.hs +++ b/tests/Graphics/Image/ColorSpaceSpec.hs @@ -26,19 +26,7 @@ arbitrary = fromComponents <$> arbitrary -instance (MArray VU cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image VU cs e) where - arbitrary = do - (Positive m, Positive n) <- arbitrary - II.makeImageM (m, n) (const arbitrary) - - -instance (MArray VS cs e, Arbitrary (Pixel cs e)) => Arbitrary (Image VS cs e) where - arbitrary = do - (Positive m, Positive n) <- arbitrary - II.makeImageM (m, n) (const arbitrary) - - -prop_ToFromComponents :: (ColorSpace cs e, Eq (Pixel cs e)) => +prop_ToFromComponents :: ColorSpace cs e => Pixel cs e -> Bool prop_ToFromComponents px = px == fromComponents (toComponents px) diff --git a/tests/Graphics/Image/IO/FormatsSpec.hs b/tests/Graphics/Image/IO/FormatsSpec.hs --- a/tests/Graphics/Image/IO/FormatsSpec.hs +++ b/tests/Graphics/Image/IO/FormatsSpec.hs @@ -11,6 +11,7 @@ import Test.QuickCheck.Property import Graphics.Image as I +import Graphics.Image.Interface as I import Graphics.Image.InterfaceSpec()