massiv-io (empty) → 0.1.0.0
raw patch · 20 files changed
+4849/−0 lines, 20 filesdep +JuicyPixelsdep +basedep +bytestringsetup-changed
Dependencies added: JuicyPixels, base, bytestring, data-default, deepseq, directory, filepath, massiv, netpbm, process, vector
Files
- LICENSE +30/−0
- README.md +2/−0
- Setup.hs +2/−0
- massiv-io.cabal +60/−0
- src/Data/Massiv/Array/IO.hs +314/−0
- src/Data/Massiv/Array/IO/Base.hs +184/−0
- src/Data/Massiv/Array/IO/Image.hs +159/−0
- src/Data/Massiv/Array/IO/Image/JuicyPixels.hs +972/−0
- src/Data/Massiv/Array/IO/Image/Netpbm.hs +217/−0
- src/Graphics/ColorSpace.hs +726/−0
- src/Graphics/ColorSpace/Binary.hs +300/−0
- src/Graphics/ColorSpace/CMYK.hs +228/−0
- src/Graphics/ColorSpace/Complex.hs +85/−0
- src/Graphics/ColorSpace/Elevator.hs +319/−0
- src/Graphics/ColorSpace/HSI.hs +211/−0
- src/Graphics/ColorSpace/Internal.hs +236/−0
- src/Graphics/ColorSpace/RGB.hs +199/−0
- src/Graphics/ColorSpace/X.hs +193/−0
- src/Graphics/ColorSpace/Y.hs +196/−0
- src/Graphics/ColorSpace/YCbCr.hs +216/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Alexey Kuleshevich (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# massiv-io+Import/export Arrays in various formats.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ massiv-io.cabal view
@@ -0,0 +1,60 @@+name: massiv-io+version: 0.1.0.0+synopsis: Import/export of Image files into massiv Arrays+description: This package contains functionality for import/export of arrays+ into the real world. For now it only has the ability to read/write+ image files in varios formats.+homepage: https://github.com/lehins/massiv+license: BSD3+license-file: LICENSE+author: Alexey Kuleshevich+maintainer: alexey@kuleshevi.ch+copyright: 2018 Alexey Kuleshevich+category: Data, Data Structures+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Graphics.ColorSpace+ , Graphics.ColorSpace.Binary+ , Graphics.ColorSpace.CMYK+ , Graphics.ColorSpace.Complex+ , Graphics.ColorSpace.HSI+ , Graphics.ColorSpace.RGB+ , Graphics.ColorSpace.X+ , Graphics.ColorSpace.Y+ , Graphics.ColorSpace.YCbCr+ , Data.Massiv.Array.IO+ other-modules: Graphics.ColorSpace.Elevator+ , Graphics.ColorSpace.Internal+ , Data.Massiv.Array.IO.Base+ , Data.Massiv.Array.IO.Image+ , Data.Massiv.Array.IO.Image.JuicyPixels+ , Data.Massiv.Array.IO.Image.Netpbm+ build-depends: base >= 4.7 && < 5+ , bytestring+ , data-default+ , deepseq+ , directory+ , filepath >= 1.0+ , massiv+ , process+ , JuicyPixels >= 3.2.7+ , netpbm+ , vector >= 0.10+ default-language: Haskell2010+ ghc-options: -Wall+ if os(windows)+ CPP-options: -DOS_Win32+ else+ if os(linux)+ CPP-options: -DOS_Linux+ else+ if os(darwin)+ CPP-options: -DOS_Mac++source-repository head+ type: git+ location: https://github.com/lehins/massiv
+ src/Data/Massiv/Array/IO.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module : Data.Massiv.Array.IO+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO (+ -- * Reading+ readArray, readImage, readImageAuto,+ -- * Writing+ writeArray ,writeImage, writeImageAuto,+ -- * Displaying+ ExternalViewer(..),+ displayImage,+ displayImageUsing,+ displayImageFile,+ -- ** Common viewers+ defaultViewer,+ eogViewer,+ gpicviewViewer,+ fehViewer,+ gimpViewer,+ -- * Supported Image Formats+ module Data.Massiv.Array.IO.Base,+ module Data.Massiv.Array.IO.Image++ -- $supported+ ) where++import Control.Concurrent (forkIO)+import Control.Exception (bracket)+import Control.Monad (void)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Massiv.Array as A+import Data.Massiv.Array.IO.Base hiding (convertEither,+ fromEitherDecode, fromMaybeEncode,+ toProxy)+import Data.Massiv.Array.IO.Image+import Graphics.ColorSpace+import Prelude as P hiding (readFile, writeFile)+import System.Directory (createDirectoryIfMissing,+ getTemporaryDirectory)+import System.FilePath+import System.IO (hClose, openBinaryTempFile)+import System.Process (readProcess)++-- | External viewing application to use for displaying images.+data ExternalViewer =+ ExternalViewer FilePath [String] Int+ -- ^ Any custom viewer, which can be specified:+ --+ -- * @FilePath@ - to the actual viewer executable.+ -- * @[String]@ - command line arguments that will be passed to the executable.+ -- * @Int@ - position index in the above list where `FilePath` to an image should be+ -- injected+ deriving Show++++-- | Read an array from one of the supported file formats.+readArray :: Readable f arr =>+ f -- ^ File format that should be used while decoding the file+ -> ReadOptions f -- ^ Any file format related decoding options. Use `def` for default.+ -> FilePath -- ^ Path to the file+ -> IO arr+readArray format opts path = decode format opts <$> B.readFile path+{-# INLINE readArray #-}+++writeArray :: Writable f arr =>+ f -- ^ Format to use while encoding the array+ -> WriteOptions f -- ^ Any file format related encoding options. Use `def` for default.+ -> FilePath+ -> arr -> IO ()+writeArray format opts path arr = BL.writeFile path (encode format opts arr)+{-# INLINE writeArray #-}+++-- | Try to guess an image format from file's extension, then attempt to decode it as such. In order+-- to supply the format manually and thus avoid this guessing technique, use `readArray`+-- instead. Color space and precision of the result array must match exactly that of the actual+-- image, in order to apply auto conversion use `readImageAuto` instead.+--+-- Might throw `ConvertError`, `DecodeError` and other standard errors related to file IO.+--+-- Result image will be read as specified by the type signature:+--+-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S YCbCr Word8)+-- >>> displayImage frog+--+-- In case when the result image type does not match the color space or precision of the actual+-- image file, `ConvertError` will be thrown.+--+-- >>> frog <- readImage "files/frog.jpg" :: IO (Image S CMYK Word8)+-- >>> displayImage frog+-- *** Exception: ConvertError "Cannot decode JPG image <Image S YCbCr Word8> as <Image S CMYK Word8>"+--+-- Whenever image is not in the color space or precision that we need, either use `readImageAuto` or+-- manually convert to the desired one by using the appropriate conversion functions:+--+-- >>> frogCMYK <- readImageAuto "files/frog.jpg" :: IO (Image S CMYK Double)+-- >>> displayImage frogCMYK+--+readImage :: (Source S Ix2 (Pixel cs e), ColorSpace cs e) =>+ FilePath -- ^ File path for an image+ -> IO (Image S cs e)+readImage path = decodeImage imageReadFormats path <$> B.readFile path+{-# INLINE readImage #-}+++-- | Same as `readImage`, but will perform any possible color space and+-- precision conversions in order to match the result image type. Very useful+-- whenever image format isn't known at compile time.+readImageAuto :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ FilePath -- ^ File path for an image+ -> IO (Image r cs e)+readImageAuto path = decodeImage imageReadAutoFormats path <$> B.readFile path+{-# INLINE readImageAuto #-}++++-- | Inverse of the 'readImage', but similarly to it, will guess an output file format from the file+-- extension and will write to file any image with the colorspace that is supported by that+-- format. Precision of the image might be adjusted using `Elevator` if precision of the source+-- array is not supported by the image file format. For instance, <'Image' @r@ 'RGBA' 'Double'>+-- being saved as 'PNG' file would be written as <'Image' @r@ 'RGBA' 'Word16'>, thus using highest+-- supported precision 'Word16' for that format. If automatic colors space is also desired,+-- `writeImageAuto` can be used instead.+--+-- Can throw `ConvertError`, `EncodeError` and other usual IO errors.+--+writeImage :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) =>+ FilePath -> Image r cs e -> IO ()+writeImage path = BL.writeFile path . encodeImage imageWriteFormats path++++writeImageAuto+ :: ( Source r Ix2 (Pixel cs e)+ , ColorSpace cs e+ , ToYA cs e+ , ToRGBA cs e+ , ToYCbCr cs e+ , ToCMYK cs e+ )+ => FilePath -> Image r cs e -> IO ()+writeImageAuto path = BL.writeFile path . encodeImage imageWriteAutoFormats path++++-- | 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 (Auto TIF) (Image r cs e) =>+-- ExternalViewer -- ^ Image viewer program+-- -> Bool -- ^ Should a call block the cuurrent thread untul viewer is closed.+-- -> Image r cs e -> IO ()+displayImageUsing :: Writable (Auto TIF) (Image r cs e) =>+ ExternalViewer -- ^ Image viewer program+ -> Bool -- ^ Should a call block the cuurrent thread untul viewer is closed.+ -> Image r cs e -> IO ()+displayImageUsing viewer block img =+ if block+ then display+ else img `seq` void (forkIO display)+ where+ display = do+ tmpDir <- fmap (</> "hip") getTemporaryDirectory+ createDirectoryIfMissing True tmpDir+ bracket+ (openBinaryTempFile tmpDir "tmp-img.tiff")+ (hClose . snd)+ (\(imgPath, imgHandle) -> do+ BL.hPut imgHandle (encode (Auto TIF) () img)+ hClose imgHandle+ displayImageFile viewer imgPath)++++-- | Displays an image file by calling an external image viewer.+displayImageFile :: ExternalViewer -> FilePath -> IO ()+displayImageFile (ExternalViewer exe args ix) imgPath =+ void $ readProcess exe (argsBefore ++ [imgPath] ++ argsAfter) ""+ where (argsBefore, argsAfter) = P.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 might take some time+-- before an image will appear.+displayImage :: Writable (Auto TIF) (Image r cs e) => Image r cs e -> IO ()+displayImage = displayImageUsing defaultViewer False++-- | Default viewer is inferred from the operating system.+defaultViewer :: ExternalViewer+defaultViewer =+#if defined(OS_Win32)+ ExternalViewer "explorer.exe" [] 0+#elif defined(OS_Linux)+ ExternalViewer "xdg-open" [] 0+#elif defined(OS_Mac)+ ExternalViewer "open" [] 0+#else+ error "Graphics.Image.IO.defaultViewer: Could not determine default viewer."+#endif+++-- | @eog \/tmp\/hip\/img.tiff@+--+-- <https://help.gnome.org/users/eog/stable/ Eye of GNOME>+eogViewer :: ExternalViewer+eogViewer = ExternalViewer "eog" [] 0+++-- | @feh --fullscreen --auto-zoom \/tmp\/hip\/img.tiff@+--+-- <https://feh.finalrewind.org/ FEH>+fehViewer :: ExternalViewer+fehViewer = ExternalViewer "feh" ["--fullscreen", "--auto-zoom"] 2+++-- | @gpicview \/tmp\/hip\/img.tiff@+--+-- <http://lxde.sourceforge.net/gpicview/ GPicView>+gpicviewViewer :: ExternalViewer+gpicviewViewer = ExternalViewer "gpicview" [] 0+++-- | @gimp \/tmp\/hip\/img.tiff@+--+-- <https://www.gimp.org/ GIMP>+gimpViewer :: ExternalViewer+gimpViewer = ExternalViewer "gimp" [] 0+++{- $supported++Encoding and decoding of images is done using+<http://hackage.haskell.org/package/JuicyPixels JuicyPixels> and+<http://hackage.haskell.org/package/netpbm netpbm> packages.++List of image formats that are currently supported, and their exact+'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')++* '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')++* 'JPG':++ * __read__: ('Y' 'Word8'), ('YA' 'Word8'), ('RGB' 'Word8'), ('CMYK' 'Word8'),+ ('YCbCr', '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')+ * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+ ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16')++* 'TGA':++ * __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')+ * __write__: ('Y' 'Word8'), ('Y' 'Word16'), ('YA' 'Word8'), ('YA' 'Word16'),+ ('RGB' 'Word8'), ('RGB' 'Word16'), ('RGBA' 'Word8'), ('RGBA' 'Word16')+ ('CMYK' 'Word8'), ('CMYK' 'Word16'), ('YCbCr' 'Word8')++* 'PBM':++ * __read__: ('Binary' 'Bit')+ * Also supports sequence of images in one file, when read as @['PBM']@++* 'PGM':++ * __read__: ('Y' 'Word8'), ('Y' 'Word16')+ * Also supports sequence of images in one file, when read as @['PGM']@++* 'PPM':++ * __read__: ('RGB' 'Word8'), ('RGB' 'Word16')+ * Also supports sequence of images in one file, when read as @['PPM']@++-}
+ src/Data/Massiv/Array/IO/Base.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Massiv.Array.IO.Base+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Base+ ( FileFormat(..)+ , Readable(..)+ , Writable(..)+ , ConvertError(..)+ , EncodeError(..)+ , DecodeError(..)+ , Sequence(..)+ , Auto(..)+ , Image+ , defaultReadOptions+ , defaultWriteOptions+ , toProxy+ , fromMaybeEncode+ , fromEitherDecode+ , convertEither+ ) where++import Control.Exception (throw, Exception)+import Data.Massiv.Array (Array, Ix2)+import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Default (Default (..))+import Data.Maybe (fromMaybe)+import Data.Typeable+import Graphics.ColorSpace (ColorSpace, Pixel)++type Image r cs e = Array r Ix2 (Pixel cs e)++-- | Conversion error, which is thrown when there is a mismatch between the+-- expected array type and the one supported by the file format. It is also+-- thrown upon a failure of automatic conversion between those types, in case+-- such conversion is utilized.+newtype ConvertError = ConvertError String deriving Show++instance Exception ConvertError++-- | This exception can be thrown while reading/decoding a file and indicates an+-- error in the file itself.+newtype DecodeError = DecodeError String deriving Show++instance Exception DecodeError++-- | This exception can be thrown while writing/encoding into a file and+-- indicates an error in an array that is being encoded.+newtype EncodeError = EncodeError String deriving Show++instance Exception EncodeError+++-- | Generate default read options for a file format+defaultReadOptions :: FileFormat f => f -> ReadOptions f+defaultReadOptions _ = def+++-- | Generate default write options for a file format+defaultWriteOptions :: FileFormat f => f -> WriteOptions f+defaultWriteOptions _ = def+++-- | Special wrapper for formats that support encoding/decoding sequence of array.+newtype Sequence f = Sequence f deriving Show++newtype Auto f = Auto f deriving Show++-- | File format. Helps in guessing file format from a file extension,+-- as well as supplying format specific options during saving the file.+class (Default (ReadOptions f), Default (WriteOptions f), Show f) => FileFormat f where+ -- | Options that can be used during reading a file in this format.+ type ReadOptions f+ type ReadOptions f = ()++ -- | Options that can be used during writing a file in this format.+ type WriteOptions f+ type WriteOptions f = ()++ -- | Default file extension for this file format.+ ext :: f -> String++ -- | Other known file extensions for this file format, eg. ".jpeg", ".jpg".+ exts :: f -> [String]+ exts f = [ext f]++ -- | Checks if a file extension corresponds to the format, eg.+ -- @isFormat ".png" PNG == True@+ isFormat :: String -> f -> Bool+ isFormat e f = e `elem` exts f+++instance FileFormat f => FileFormat (Auto f) where+ type ReadOptions (Auto f) = ReadOptions f+ type WriteOptions (Auto f) = WriteOptions f++ ext (Auto f) = ext f++-- | File formats that can be read into an Array.+class Readable f arr where++ -- | Decode a `B.ByteString` into an Array.+ decode :: f -> ReadOptions f -> B.ByteString -> arr+++-- | Arrays that can be written into a file.+class Writable f arr where++ -- | Encode an array into a `BL.ByteString`.+ encode :: f -> WriteOptions f -> arr -> BL.ByteString+++-- | Helper function to create a `Proxy` from the value.+toProxy :: a -> Proxy a+toProxy _ = Proxy++-- | Encode an image using the supplied function or throw an error in case of failure.+fromMaybeEncode+ :: forall f r cs e b. (ColorSpace cs e, FileFormat f, Typeable r)+ => f -> Proxy (Image r cs e) -> Maybe b -> b+fromMaybeEncode _ _ (Just b) = b+fromMaybeEncode f _imgProxy Nothing =+ throw $+ ConvertError+ ("Format " +++ show f +++ " cannot be encoded as <Image " +++ showsTypeRep (typeRep (Proxy :: Proxy r)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy cs)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy e)) ">")+++-- | Decode an image using the supplied function or throw an error in case of failure.+fromEitherDecode :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) =>+ f+ -> (a -> String)+ -> (a -> Maybe (Image r cs e))+ -> Either String a+ -> Image r cs e+fromEitherDecode _ _ _ (Left err) = throw $ DecodeError err+fromEitherDecode f showCS conv (Right eImg) =+ fromMaybe+ (throw $+ ConvertError+ ("Cannot decode " ++ show f ++ " image <" +++ showCS eImg +++ "> as " +++ "<Image " +++ showsTypeRep (typeRep (Proxy :: Proxy r)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy cs)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy e)) ">"))+ (conv eImg)+++-- | Convert an image using the supplied function and return ConvertError error in case of failure.+convertEither :: forall r cs e a f. (ColorSpace cs e, FileFormat f, Typeable r) =>+ f+ -> (a -> String)+ -> (a -> Maybe (Image r cs e))+ -> a+ -> Either ConvertError (Image r cs e)+convertEither f showCS conv eImg =+ maybe+ (Left $+ ConvertError+ ("Cannot convert " ++ show f ++ " image <" +++ showCS eImg +++ "> as " +++ "<Image " +++ showsTypeRep (typeRep (Proxy :: Proxy r)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy cs)) " " +++ showsTypeRep (typeRep (Proxy :: Proxy e)) ">"))+ Right+ (conv eImg)
+ src/Data/Massiv/Array/IO/Image.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module : Data.Massiv.Array.IO.Image+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image+ ( Encode+ , encodeImage+ , imageWriteFormats+ , imageWriteAutoFormats+ , Decode+ , decodeImage+ , imageReadFormats+ , imageReadAutoFormats+ , module Data.Massiv.Array.IO.Image.JuicyPixels+ , module Data.Massiv.Array.IO.Image.Netpbm+ ) where++import Control.Exception (throw)+import Data.Massiv.Array+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels+import Data.Massiv.Array.IO.Image.Netpbm+import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Char (toLower)+import Graphics.ColorSpace+import Prelude as P+import System.FilePath (takeExtension)++++data Encode out where+ EncodeAs :: (FileFormat f, Writable f out) => f -> Encode out++instance Show (Encode out) where+ show (EncodeAs f) = show f++instance FileFormat (Encode (Image r cs e)) where+ ext (EncodeAs f) = ext f++ exts (EncodeAs f) = exts f++instance Writable (Encode (Image r cs e)) (Image r cs e) where+ encode (EncodeAs f) _ = encode f (defaultWriteOptions f)+++encodeImage+ :: (Source r Ix2 (Pixel cs e), ColorSpace cs e)+ => [Encode (Image r cs e)]+ -> FilePath+ -> Image r cs e+ -> BL.ByteString+encodeImage formats path img = do+ let ext' = P.map toLower . takeExtension $ path+ case dropWhile (not . isFormat ext') formats of+ [] -> throw $ EncodeError $ "File format is not supported: " ++ ext'+ (f:_) -> encode f () img+++imageWriteFormats :: (Source r Ix2 (Pixel cs e), ColorSpace cs e) => [Encode (Image r cs e)]+imageWriteFormats =+ [ EncodeAs BMP+ , EncodeAs GIF+ , EncodeAs HDR+ , EncodeAs JPG+ , EncodeAs PNG+ , EncodeAs TGA+ , EncodeAs TIF+ ]++imageWriteAutoFormats+ :: ( Source r Ix2 (Pixel cs e)+ , ColorSpace cs e+ , ToYA cs e+ , ToRGBA cs e+ , ToYCbCr cs e+ , ToCMYK cs e+ )+ => [Encode (Image r cs e)]+imageWriteAutoFormats =+ [ EncodeAs (Auto BMP)+ , EncodeAs (Auto GIF)+ , EncodeAs (Auto HDR)+ , EncodeAs (Auto JPG)+ , EncodeAs (Auto PNG)+ , EncodeAs (Auto TGA)+ , EncodeAs (Auto TIF)+ ]++++data Decode out where+ DecodeAs :: (FileFormat f, Readable f out) => f -> Decode out++instance Show (Decode out) where+ show (DecodeAs f) = show f++instance FileFormat (Decode (Image r cs e)) where+ ext (DecodeAs f) = ext f++ exts (DecodeAs f) = exts f++instance Readable (Decode (Image r cs e)) (Image r cs e) where+ decode (DecodeAs f) _ = decode f (defaultReadOptions f)+++decodeImage+ :: (Source r Ix2 (Pixel cs e), ColorSpace cs e)+ => [Decode (Image r cs e)]+ -> FilePath+ -> B.ByteString+ -> Image r cs e+decodeImage formats path bs = do+ let ext' = P.map toLower . takeExtension $ path+ case dropWhile (not . isFormat ext') formats of+ [] -> throw $ DecodeError $ "File format is not supported: " ++ ext'+ (f:_) -> decode f () bs+++imageReadFormats+ :: (Source S Ix2 (Pixel cs e), ColorSpace cs e)+ => [Decode (Image S cs e)]+imageReadFormats =+ [ DecodeAs BMP+ , DecodeAs GIF+ , DecodeAs HDR+ , DecodeAs JPG+ , DecodeAs PNG+ , DecodeAs TGA+ , DecodeAs TIF+ , DecodeAs PBM+ , DecodeAs PGM+ , DecodeAs PPM+ ]++imageReadAutoFormats+ :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e)+ => [Decode (Image r cs e)]+imageReadAutoFormats =+ [ DecodeAs (Auto BMP)+ , DecodeAs (Auto GIF)+ , DecodeAs (Auto HDR)+ , DecodeAs (Auto JPG)+ , DecodeAs (Auto PNG)+ , DecodeAs (Auto TGA)+ , DecodeAs (Auto TIF)+ , DecodeAs (Auto PBM)+ , DecodeAs (Auto PGM)+ , DecodeAs (Auto PPM)+ ]
+ src/Data/Massiv/Array/IO/Image/JuicyPixels.hs view
@@ -0,0 +1,972 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+-- |+-- Module : Data.Massiv.Array.IO.Image.JuicyPixels+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.JuicyPixels+ ( -- * JuicyPixels formats+ -- ** BMP+ BMP(..)+ -- ** GIF+ , GIF(..)+ , WriteOptionsGIF+ , woGetPaletteOptionsGIF+ , woSetPaletteOptionsGIF+ , JP.PaletteOptions(..)+ , JP.PaletteCreationMethod(..)+ -- *** Animated+ , WriteOptionsSequenceGIF+ , woGetGifLoopingGIFs+ , woGetPaletteOptionsGIFs+ , woSetGifLoopingGIFs+ , woSetPaletteOptionsGIFs+ , JP.GifDelay+ , JP.GifLooping(..)+ -- ** HDR+ , HDR(..)+ -- ** JPG+ , JPG(..)+ , WriteOptionsJPG+ , woGetQualityJPG+ , woSetQualityJPG+ -- ** PNG+ , PNG(..)+ -- ** TGA+ , TGA(..)+ -- ** TIF+ , TIF(..)+ -- * JuciyPixels conversion+ -- ** To JuicyPixels+ -- O(1) Conversion to JuicyPixels images+ , toAnyCS+ , toJPImageY8+ , toJPImageYA8+ , toJPImageY16+ , toJPImageYA16+ , toJPImageYF+ , toJPImageRGB8+ , toJPImageRGBA8+ , toJPImageRGB16+ , toJPImageRGBA16+ , toJPImageRGBF+ , toJPImageYCbCr8+ , toJPImageCMYK8+ -- , toJPImageCMYK16+ -- ** From JuicyPixels+ ) where++import Prelude as P++import qualified Codec.Picture as JP+import qualified Codec.Picture.ColorQuant as JP+import qualified Codec.Picture.Gif as JP+import qualified Codec.Picture.Jpg as JP+import Control.Exception+import Control.Monad (guard, msum)+import Data.Bifunctor+import qualified Data.ByteString as B (ByteString)+import qualified Data.ByteString.Lazy as BL (ByteString)+import Data.Default (Default (..))+import Data.Massiv.Array as M+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.Manifest.Vector+import Data.Typeable+import qualified Data.Vector.Storable as V+import Graphics.ColorSpace+--------------------------------------------------------------------------------+-- BMP Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Bitmap image with @.bmp@ extension.+data BMP = BMP deriving Show++instance FileFormat BMP where++ ext _ = ".bmp"+++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable BMP (Image r cs e) where+ encode f _ img = fromMaybeEncode f (toProxy img) $ encodeBMP img++instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto BMP) (Image r cs e) where+ encode f _ = encodeAuto f encodeBMP id toPixelRGBA toPixelRGB toPixelRGBA+++instance ColorSpace cs e => Readable BMP (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeBitmap+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto BMP) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeBitmap+++encodeBMP :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => Image r cs e -> Maybe BL.ByteString+encodeBMP img =+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeBitmap $ toJPImageY8 img+ , return $ JP.encodeBitmap $ toJPImageY8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeBitmap $ toJPImageRGB8 img+ , return $ JP.encodeBitmap $ toJPImageRGB8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeBitmap $ toJPImageRGBA8 img+ , return $ JP.encodeBitmap $ toJPImageRGBA8 $ M.map toWord8 img+ ]+ ]+++--------------------------------------------------------------------------------+-- PNG Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Portable Network Graphics image with @.png@ extension.+data PNG = PNG deriving Show++instance FileFormat PNG where++ ext _ = ".png"++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable PNG (Image r cs e) where+ encode f _ img = fromMaybeEncode f (toProxy img) (encodePNG img)+++instance (ColorSpace cs e, ToYA cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto PNG) (Image r cs e) where+ encode f _ = encodeAuto f encodePNG id toPixelYA toPixelRGB toPixelRGBA+++instance ColorSpace cs e => Readable PNG (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodePng++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto PNG) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodePng++++encodePNG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => Image r cs e -> Maybe BL.ByteString+encodePNG img =+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodePng $ toJPImageY8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodePng $ toJPImageY16 img+ , return $ JP.encodePng $ toJPImageY16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: YA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodePng $ toJPImageYA8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodePng $ toJPImageYA16 img+ , return $ JP.encodePng $ toJPImageYA16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodePng $ toJPImageRGB8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodePng $ toJPImageRGB16 img+ , return $ JP.encodePng $ toJPImageRGB16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodePng $ toJPImageRGBA8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodePng $ toJPImageRGBA16 img+ , return $ JP.encodePng $ toJPImageRGBA16 $ M.map toWord16 img+ ]+ ]++++--------------------------------------------------------------------------------+-- GIF Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++-- | Graphics Interchange Format image with @.gif@ extension.+data GIF = GIF deriving Show++newtype WriteOptionsGIF = WriteOptionsGIF+ { woGetPaletteOptionsGIF :: JP.PaletteOptions+ }++woSetPaletteOptionsGIF :: JP.PaletteOptions -> WriteOptionsGIF -> WriteOptionsGIF+woSetPaletteOptionsGIF palOpts opts = opts { woGetPaletteOptionsGIF = palOpts }++instance Default WriteOptionsGIF where+ def = WriteOptionsGIF JP.defaultPaletteOptions++instance FileFormat GIF where+ type WriteOptions GIF = WriteOptionsGIF++ ext _ = ".gif"+++data WriteOptionsSequenceGIF = WriteOptionsSequenceGIF+ { woGetPaletteOptionsGIFs :: JP.PaletteOptions+ , woGetGifLoopingGIFs :: JP.GifLooping+ }++woSetPaletteOptionsGIFs :: JP.PaletteOptions -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF+woSetPaletteOptionsGIFs palOpts opts = opts { woGetPaletteOptionsGIFs = palOpts }+++woSetGifLoopingGIFs :: JP.GifLooping -> WriteOptionsSequenceGIF -> WriteOptionsSequenceGIF+woSetGifLoopingGIFs looping opts = opts { woGetGifLoopingGIFs = looping }+++instance Default WriteOptionsSequenceGIF where+ def = WriteOptionsSequenceGIF JP.defaultPaletteOptions JP.LoopingNever++instance FileFormat (Sequence GIF) where++ type WriteOptions (Sequence GIF) = WriteOptionsSequenceGIF+ ext _ = ext GIF+++instance FileFormat (Sequence (Auto GIF)) where++ type WriteOptions (Sequence (Auto GIF)) = WriteOptions (Sequence GIF)+ ext _ = ext GIF+++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable GIF (Image r cs e) where+ encode f opt img = fromMaybeEncode f (toProxy img) $ encodeGIF opt img++instance (ColorSpace cs e, ToY cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto GIF) (Image r cs e) where+ encode f opt = encodeAuto f (encodeGIF opt) id toPixelY toPixelRGB toPixelRGB+++instance ColorSpace cs e => Readable GIF (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeGif++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto GIF) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeGif+++++instance ColorSpace cs e =>+ Readable (Sequence GIF) (Array B Ix1 (Image S cs e)) where+ decode f _ bs = decodeGIFs f fromDynamicImage bs++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Sequence (Auto GIF)) (Array B Ix1 (Image r cs e)) where+ decode f _ bs = decodeGIFs f fromAnyDynamicImage bs+++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image r cs e)) where+ encode _ opts =+ fromMaybeEncode (Sequence GIF) (Proxy :: Proxy (Image r cs e)) . encodeGIFs opts+++instance ColorSpace cs e =>+ Readable (Sequence GIF) (Array B Ix1 (JP.GifDelay, Image S cs e)) where+ decode f _ bs = decodeGIFsWithDelays f fromDynamicImage bs++++-- Animated GIF Format frames reading into an Array of Images++decodeGIFs+ :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e)+ => f+ -> (JP.DynamicImage -> Maybe (Image r cs e))+ -> B.ByteString+ -> Array B Ix1 (Image r cs e)+decodeGIFs f converter bs =+ either throw (fromList Seq) $ do+ jpImgs <- first (toException . DecodeError) $ JP.decodeGifImages bs+ first toException $ mapM (convertEither f showJP converter) jpImgs+ -- either+ -- (throw . DecodeError)+ -- (fromList' Seq)+ -- (P.map (fromEitherDecode f showJP decoder . Right) <$> JP.decodeGifImages bs)+{-# INLINE decodeGIFs #-}++++decodeGIFsWithDelays+ :: ColorSpace cs e+ => Sequence GIF+ -> (JP.DynamicImage -> Maybe (Image S cs e))+ -> B.ByteString+ -> Array B Ix1 (JP.GifDelay, Image S cs e)+decodeGIFsWithDelays f converter bs =+ either throw (fromList Seq) $ do+ jpImgsLs <- first (toException . DecodeError) $ JP.decodeGifImages bs+ delays <- first (toException . DecodeError) $ JP.getDelaysGifImages bs+ imgs <- first toException $ mapM (convertEither f showJP converter) jpImgsLs+ return $ P.zip delays imgs+{-# INLINE decodeGIFsWithDelays #-}++++encodeGIF :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => WriteOptionsGIF+ -> Image r cs e+ -> Maybe BL.ByteString+encodeGIF (WriteOptionsGIF pal) img =+ (either (throw . EncodeError) id . uncurry JP.encodeGifImageWithPalette) <$>+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ jImg <-+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ toJPImageY8 img+ , return $ toJPImageY8 $ M.map toWord8 img+ ]+ return (jImg, JP.greyPalette)+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ palettizeRGB pal img+ , palettizeRGB pal $ M.map toWord8 img+ ]+ ]+++encodeGIFs :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => WriteOptionsSequenceGIF+ -> Array B Ix1 (JP.GifDelay, Image r cs e)+ -> Maybe BL.ByteString+encodeGIFs (WriteOptionsSequenceGIF pal looping) arr = do+ palImgsLs <-+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ P.map ((, JP.greyPalette) . toJPImageY8) imgsLs+ , return $+ P.map ((, JP.greyPalette) . toJPImageY8 . M.map toWord8) imgsLs+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ P.mapM (palettizeRGB pal) imgsLs+ , P.mapM (palettizeRGB pal . M.map toWord8) imgsLs+ ]+ ]+ let palDelImgsLs = P.zipWith (\(i, p) d -> (p, d, i)) palImgsLs delaysLs+ return $+ either (throw . EncodeError) id $ JP.encodeGifImages looping palDelImgsLs+ where+ delaysLs = toList delays+ imgsLs = toList imgs+ (delays, imgs) = M.unzip arr+{-# INLINE encodeGIFs #-}+++palettizeRGB :: forall r e . (ColorSpace RGB e, Source r Ix2 (Pixel RGB e))+ => JP.PaletteOptions+ -> Image r RGB e+ -> Maybe (JP.Image JP.Pixel8, JP.Palette)+palettizeRGB pal img = do+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ palettize' img+ , return $ palettize' $ M.map toWord8 img+ ]+ where+ palettize' :: forall r' . Source r' Ix2 (Pixel RGB Word8) =>+ Image r' RGB Word8 -> (JP.Image JP.Pixel8, JP.Palette)+ palettize' = JP.palettize pal . toJPImageRGB8+ {-# INLINE palettize' #-}+{-# INLINE palettizeRGB #-}+++--------------------------------------------------------------------------------+-- HDR Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++-- | High-dynamic-range image with @.hdr@ or @.pic@ extension.+data HDR = HDR deriving Show++instance FileFormat HDR where++ ext _ = ".hdr"++ exts _ = [".hdr", ".pic"]++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable HDR (Image r cs e) where+ encode f _ img = fromMaybeEncode f (toProxy img) $ encodeHDR img+++instance (ColorSpace cs e, ToRGB cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto HDR) (Image r cs e) where+ encode f _ =+ encodeAuto f encodeHDR toPixelRGB toPixelRGB toPixelRGB toPixelRGB+++instance ColorSpace cs e => Readable HDR (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodePng++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto HDR) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodePng+++++encodeHDR :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => Image r cs e -> Maybe BL.ByteString+encodeHDR img = do+ Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Float)+ return $ JP.encodeHDR $ toJPImageRGBF img+ , return $ JP.encodeHDR $ toJPImageRGBF $ M.map toFloat img+ ]+++++--------------------------------------------------------------------------------+-- JPG Format ------------------------------------------------------------------+--------------------------------------------------------------------------------++newtype WriteOptionsJPG = WriteOptionsJPG { woGetQualityJPG :: Word8 } deriving Show++-- | Set the image quality, supplied value will be clamped to @[0, 100]@+-- range. This setting directly affects the Jpeg compression level.+woSetQualityJPG :: Word8 -> WriteOptionsJPG -> WriteOptionsJPG+woSetQualityJPG q opts = opts { woGetQualityJPG = min 100 (max 0 q) }++instance Default WriteOptionsJPG where+ def = WriteOptionsJPG 100++-- | Joint Photographic Experts Group image with @.jpg@ or @.jpeg@ extension.+data JPG = JPG deriving Show++instance FileFormat JPG where+ type WriteOptions JPG = WriteOptionsJPG++ ext _ = ".jpg"++ exts _ = [".jpg", ".jpeg"]++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable JPG (Image r cs e) where+ encode f opts img = fromMaybeEncode f (toProxy img) $ encodeJPG opts img+++instance (ColorSpace cs e, ToYCbCr cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto JPG) (Image r cs e) where+ encode f opt =+ encodeAuto f (encodeJPG opt) toPixelYCbCr toPixelYCbCr toPixelYCbCr toPixelYCbCr+++instance ColorSpace cs e => Readable JPG (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeJpeg++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto JPG) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeJpeg+++++encodeJPG :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => WriteOptionsJPG -> Image r cs e -> Maybe BL.ByteString+encodeJPG (WriteOptionsJPG q) img =+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ encJPG $ toJPImageY8 img+ , return $ encJPG $ toJPImageY8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ encJPG $ toJPImageRGB8 img+ , return $ encJPG $ toJPImageRGB8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: CMYK)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ encJPG $ toJPImageCMYK8 img+ , return $ encJPG $ toJPImageCMYK8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: YCbCr)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ encJPG $ toJPImageYCbCr8 img+ , return $ encJPG $ toJPImageYCbCr8 $ M.map toWord8 img+ ]+ ]+ where+ encJPG :: forall px . JP.JpgEncodable px => JP.Image px -> BL.ByteString+ encJPG = JP.encodeDirectJpegAtQualityWithMetadata q mempty+ {-# INLINE encJPG #-}++++--------------------------------------------------------------------------------+-- TGA Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++-- | Truevision Graphics Adapter image with .tga extension.+data TGA = TGA deriving Show++instance FileFormat TGA where++ ext _ = ".tga"+ {-# INLINE ext #-}++++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable TGA (Image r cs e) where+ encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTGA img++instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto TGA) (Image r cs e) where+ encode f _ = encodeAuto f encodeTGA id toPixelRGBA toPixelRGB toPixelRGBA+++instance ColorSpace cs e => Readable TGA (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTga+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto TGA) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTga+++encodeTGA :: forall r cs e . (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => Image r cs e -> Maybe BL.ByteString+encodeTGA img =+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTga $ toJPImageY8 img+ , return $ JP.encodeTga $ toJPImageY8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTga $ toJPImageRGB8 img+ , return $ JP.encodeTga $ toJPImageRGB8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTga $ toJPImageRGBA8 img+ , return $ JP.encodeTga $ toJPImageRGBA8 $ M.map toWord8 img+ ]+ ]+++--------------------------------------------------------------------------------+-- TIF Format ------------------------------------------------------------------+--------------------------------------------------------------------------------+++-- | Tagged Image File Format image with @.tif@ or @.tiff@ extension.+data TIF = TIF deriving Show++instance FileFormat TIF where++ ext _ = ".tif"+ {-# INLINE ext #-}++ exts _ = [".tif", ".tiff"]+ {-# INLINE exts #-}+++instance (ColorSpace cs e, Source r Ix2 (Pixel cs e)) =>+ Writable TIF (Image r cs e) where+ encode f _ img = fromMaybeEncode f (toProxy img) $ encodeTIF img+++instance (ColorSpace cs e, ToRGBA cs e, Source r Ix2 (Pixel cs e)) =>+ Writable (Auto TIF) (Image r cs e) where+ encode f _ = encodeAuto f encodeTIF id id id toPixelRGBA+++instance ColorSpace cs e => Readable TIF (Image S cs e) where+ decode f _ = fromEitherDecode f showJP fromDynamicImage . JP.decodeTiff++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto TIF) (Image r cs e) where+ decode f _ = fromEitherDecode f showJP fromAnyDynamicImage . JP.decodeTiff+++++encodeTIF :: forall r cs e. (ColorSpace cs e, Source r Ix2 (Pixel cs e))+ => Image r cs e -> Maybe BL.ByteString+encodeTIF img =+ msum+ [ do Refl <- eqT :: Maybe (cs :~: Y)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageY8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodeTiff $ toJPImageY16 img+ , return $ JP.encodeTiff $ toJPImageY16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: YA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageYA8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodeTiff $ toJPImageYA16 img+ , return $ JP.encodeTiff $ toJPImageYA16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageRGB8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodeTiff $ toJPImageRGB16 img+ , return $ JP.encodeTiff $ toJPImageRGB16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageRGBA8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ JP.encodeTiff $ toJPImageRGBA16 img+ , return $ JP.encodeTiff $ toJPImageRGBA16 $ M.map toWord16 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: YCbCr)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageYCbCr8 img+ , return $ JP.encodeTiff $ toJPImageYCbCr8 $ M.map toWord8 img+ ]+ , do Refl <- eqT :: Maybe (cs :~: CMYK)+ msum+ [ do Refl <- eqT :: Maybe (e :~: Word8)+ return $ JP.encodeTiff $ toJPImageCMYK8 img+ -- , do Refl <- eqT :: Maybe (e :~: Word16)+ -- return $ JP.encodeTiff $ toJPImageCMYK16 img+ , return $ JP.encodeTiff $ toJPImageCMYK8 $ M.map toWord8 img+ ]+ ]+++++--------------------------------------------------------------------------------+-- Common encoding/decoding functions ------------------------------------------+--------------------------------------------------------------------------------+++encodeAuto+ :: forall f r cs e a csY eY csYA eYA csC eC csCA eCA.+ ( ColorSpace cs e+ , ColorSpace csC eC+ , ColorSpace csCA eCA+ , ColorSpace csY eY+ , ColorSpace csYA eYA+ , Source r Ix2 (Pixel cs e)+ , FileFormat f+ )+ => f+ -> (forall r' cs' e'. (Source r' Ix2 (Pixel cs' e'), ColorSpace cs' e') =>+ Image r' cs' e' -> Maybe a)+ -> (Pixel cs e -> Pixel csY eY) -- ^ To preferred from Luma+ -> (Pixel cs e -> Pixel csYA eYA) -- ^ To preferred from Luma with Alpha+ -> (Pixel cs e -> Pixel csC eC) -- ^ To preferred from any color+ -> (Pixel cs e -> Pixel csCA eCA) -- ^ To preferred from any color with Alpha+ -> Image r cs e+ -> a+encodeAuto f enc toLuma toLumaA toColor toColorA img =+ fromMaybeEncode f (toProxy img) $ msum+ [ enc img+ , do Refl <- eqT :: Maybe (cs :~: Y)+ enc $ M.map toLuma img+ , do Refl <- eqT :: Maybe (cs :~: YA)+ enc $ M.map toLumaA img+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ enc $ M.map toColor img+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ enc $ M.map toColorA img+ , do Refl <- eqT :: Maybe (cs :~: HSI)+ enc $ M.map toColor img+ , do Refl <- eqT :: Maybe (cs :~: HSIA)+ enc $ M.map toColorA img+ , do Refl <- eqT :: Maybe (cs :~: YCbCr)+ enc $ M.map toColor img+ , do Refl <- eqT :: Maybe (cs :~: YCbCrA)+ enc $ M.map toColorA img+ , do Refl <- eqT :: Maybe (cs :~: CMYK)+ enc $ M.map toColor img+ , do Refl <- eqT :: Maybe (cs :~: CMYKA)+ enc $ M.map toColorA img+ , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)+ enc $ M.map fromPixelBinary img+ ]+++++elevate+ :: forall cs e' e.+ ( Functor (Pixel cs)+ , ColorSpace cs e'+ , ColorSpace cs e+ , Source D Ix2 (Pixel cs e')+ )+ => Image D cs e' -> Maybe (Image D cs e)+elevate img =+ msum+ [ fmap (\Refl -> img) (eqT :: Maybe (e :~: e'))+ , do Refl <- eqT :: Maybe (e :~: Word8)+ return $ M.map toWord8 img+ , do Refl <- eqT :: Maybe (e :~: Word16)+ return $ M.map toWord16 img+ , do Refl <- eqT :: Maybe (e :~: Word32)+ return $ M.map toWord32 img+ , do Refl <- eqT :: Maybe (e :~: Word64)+ return $ M.map toWord64 img+ , do Refl <- eqT :: Maybe (e :~: Double)+ return $ M.map toDouble img+ ]++fromDynamicImage :: forall cs e . (ColorSpace cs e, Source S Ix2 (Pixel cs e))+ => JP.DynamicImage -> Maybe (Image S cs e)+fromDynamicImage jpDynImg =+ case jpDynImg of+ JP.ImageY8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8)+ fromJPImageUnsafe jimg+ JP.ImageY16 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16)+ fromJPImageUnsafe jimg+ JP.ImageYF jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Float)+ fromJPImageUnsafe jimg+ JP.ImageYA8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word8)+ fromJPImageUnsafe jimg+ JP.ImageYA16 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YA Word16)+ fromJPImageUnsafe jimg+ JP.ImageRGB8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8)+ fromJPImageUnsafe jimg+ JP.ImageRGB16 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16)+ fromJPImageUnsafe jimg+ JP.ImageRGBF jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Float)+ fromJPImageUnsafe jimg+ JP.ImageRGBA8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word8)+ fromJPImageUnsafe jimg+ JP.ImageRGBA16 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGBA Word16)+ fromJPImageUnsafe jimg+ JP.ImageYCbCr8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel YCbCr Word8)+ fromJPImageUnsafe jimg+ JP.ImageCMYK8 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word8)+ fromJPImageUnsafe jimg+ JP.ImageCMYK16 jimg -> do+ Refl <- eqT :: Maybe (Pixel cs e :~: Pixel CMYK Word16)+ fromJPImageUnsafe jimg++++fromAnyDynamicImage :: (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ JP.DynamicImage -> Maybe (Image r cs e)+fromAnyDynamicImage jpDynImg = do+ case jpDynImg of+ JP.ImageY8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word8)) >>= toAnyCS+ JP.ImageY16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Word16)) >>= toAnyCS+ JP.ImageYF jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S Y Float)) >>= toAnyCS+ JP.ImageYA8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word8)) >>= toAnyCS+ JP.ImageYA16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YA Word16)) >>= toAnyCS+ JP.ImageRGB8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word8)) >>= toAnyCS+ JP.ImageRGB16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Word16)) >>= toAnyCS+ JP.ImageRGBF jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGB Float)) >>= toAnyCS+ JP.ImageRGBA8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word8)) >>= toAnyCS+ JP.ImageRGBA16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S RGBA Word16)) >>= toAnyCS+ JP.ImageYCbCr8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S YCbCr Word8)) >>= toAnyCS+ JP.ImageCMYK8 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word8)) >>= toAnyCS+ JP.ImageCMYK16 jimg -> (fromJPImageUnsafe jimg :: Maybe (Image S CMYK Word16)) >>= toAnyCS+++toAnyCS+ :: forall r' cs' e' r cs e.+ ( Source r' Ix2 (Pixel cs' e')+ , Mutable r Ix2 (Pixel cs e)+ , Storable (Pixel cs e)+ , ColorSpace cs e+ , ToYA cs' e'+ , ToRGBA cs' e'+ , ToHSIA cs' e'+ , ToCMYKA cs' e'+ , ToYCbCrA cs' e'+ )+ => Image r' cs' e' -> Maybe (Image r cs e)+toAnyCS img =+ msum+ [ (\Refl -> computeSource img) <$>+ (eqT :: Maybe (Pixel cs' e' :~: Pixel cs e))+ , do Refl <- eqT :: Maybe (cs :~: Y)+ compute <$> elevate (M.map toPixelY img)+ , do Refl <- eqT :: Maybe (cs :~: YA)+ compute <$> elevate (M.map toPixelYA img)+ , do Refl <- eqT :: Maybe (cs :~: RGB)+ compute <$> elevate (M.map toPixelRGB img)+ , do Refl <- eqT :: Maybe (cs :~: RGBA)+ compute <$> elevate (M.map toPixelRGBA img)+ , do Refl <- eqT :: Maybe (cs :~: HSI)+ compute <$> elevate (M.map toPixelHSI img)+ , do Refl <- eqT :: Maybe (cs :~: HSIA)+ compute <$> elevate (M.map toPixelHSIA img)+ , do Refl <- eqT :: Maybe (cs :~: CMYK)+ compute <$> elevate (M.map toPixelCMYK img)+ , do Refl <- eqT :: Maybe (cs :~: CMYKA)+ compute <$> elevate (M.map toPixelCMYKA img)+ , do Refl <- eqT :: Maybe (cs :~: YCbCr)+ compute <$> elevate (M.map toPixelYCbCr img)+ , do Refl <- eqT :: Maybe (cs :~: YCbCrA)+ compute <$> elevate (M.map toPixelYCbCrA img)+ , do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)+ return $ compute $ M.map toPixelBinary img+ ]++++showJP :: JP.DynamicImage -> String+showJP (JP.ImageY8 _) = "Image S Y Word8"+showJP (JP.ImageY16 _) = "Image S Y Word16"+showJP (JP.ImageYF _) = "Image S Y Float"+showJP (JP.ImageYA8 _) = "Image S YA Word8"+showJP (JP.ImageYA16 _) = "Image S YA Word16"+showJP (JP.ImageRGB8 _) = "Image S RGB Word8"+showJP (JP.ImageRGB16 _) = "Image S RGB Word16"+showJP (JP.ImageRGBF _) = "Image S RGB Float"+showJP (JP.ImageRGBA8 _) = "Image S RGBA Word8"+showJP (JP.ImageRGBA16 _) = "Image S RGBA Word16"+showJP (JP.ImageYCbCr8 _) = "Image S YCbCr Word8"+showJP (JP.ImageCMYK8 _) = "Image S CMYK Word8"+showJP (JP.ImageCMYK16 _) = "Image S CMYK Word16"+++-- Encoding++-- | TODO: Validate size+toJPImageUnsafe+ :: forall r cs a . (JP.Pixel a, Source r Ix2 (Pixel cs (JP.PixelBaseComponent a)),+ ColorSpace cs (JP.PixelBaseComponent a),+ Storable (Pixel cs (JP.PixelBaseComponent a)))+ => Image r cs (JP.PixelBaseComponent a)+ -> JP.Image a+toJPImageUnsafe img = JP.Image n m $ V.unsafeCast $ toVector arrS where+ !arrS = computeSource img :: Image S cs (JP.PixelBaseComponent a)+ (m :. n) = size img+{-# INLINE toJPImageUnsafe #-}++toJPImageY8 :: Source r Ix2 (Pixel Y Word8) => Image r Y Word8 -> JP.Image JP.Pixel8+toJPImageY8 = toJPImageUnsafe+{-# INLINE toJPImageY8 #-}++toJPImageY16 :: Source r Ix2 (Pixel Y Word16) => Image r Y Word16 -> JP.Image JP.Pixel16+toJPImageY16 = toJPImageUnsafe+{-# INLINE toJPImageY16 #-}++toJPImageYA8 :: Source r Ix2 (Pixel YA Word8) => Image r YA Word8 -> JP.Image JP.PixelYA8+toJPImageYA8 = toJPImageUnsafe+{-# INLINE toJPImageYA8 #-}++toJPImageYA16 :: Source r Ix2 (Pixel YA Word16) => Image r YA Word16 -> JP.Image JP.PixelYA16+toJPImageYA16 = toJPImageUnsafe+{-# INLINE toJPImageYA16 #-}++toJPImageYF :: Source r Ix2 (Pixel Y Float) => Image r Y Float -> JP.Image JP.PixelF+toJPImageYF = toJPImageUnsafe+{-# INLINE toJPImageYF #-}++toJPImageRGB8 :: Source r Ix2 (Pixel RGB Word8) => Image r RGB Word8 -> JP.Image JP.PixelRGB8+toJPImageRGB8 = toJPImageUnsafe+{-# INLINE toJPImageRGB8 #-}++toJPImageRGBA8 :: Source r Ix2 (Pixel RGBA Word8) => Image r RGBA Word8 -> JP.Image JP.PixelRGBA8+toJPImageRGBA8 = toJPImageUnsafe+{-# INLINE toJPImageRGBA8 #-}++toJPImageRGB16 :: Source r Ix2 (Pixel RGB Word16) => Image r RGB Word16 -> JP.Image JP.PixelRGB16+toJPImageRGB16 = toJPImageUnsafe+{-# INLINE toJPImageRGB16 #-}++toJPImageRGBA16 :: Source r Ix2 (Pixel RGBA Word16) => Image r RGBA Word16 -> JP.Image JP.PixelRGBA16+toJPImageRGBA16 = toJPImageUnsafe+{-# INLINE toJPImageRGBA16 #-}++toJPImageRGBF :: Source r Ix2 (Pixel RGB Float) => Image r RGB Float -> JP.Image JP.PixelRGBF+toJPImageRGBF = toJPImageUnsafe+{-# INLINE toJPImageRGBF #-}++toJPImageYCbCr8 :: Source r Ix2 (Pixel YCbCr Word8) => Image r YCbCr Word8 -> JP.Image JP.PixelYCbCr8+toJPImageYCbCr8 = toJPImageUnsafe+{-# INLINE toJPImageYCbCr8 #-}++toJPImageCMYK8 :: Source r Ix2 (Pixel CMYK Word8) => Image r CMYK Word8 -> JP.Image JP.PixelCMYK8+toJPImageCMYK8 = toJPImageUnsafe+{-# INLINE toJPImageCMYK8 #-}++-- FIXME: debug writing to file of TIF files.+-- toJPImageCMYK16 :: Source r Ix2 (Pixel CMYK Word16) => Image r CMYK Word16 -> JP.Image JP.PixelCMYK16+-- toJPImageCMYK16 = toJPImageUnsafe+-- {-# INLINE toJPImageCMYK16 #-}+++++-- General decoding and helper functions++-- | TODO: Validate size+fromJPImageUnsafe :: (Storable (Pixel cs e), JP.Pixel jpx) =>+ JP.Image jpx -> Maybe (Image S cs e)+fromJPImageUnsafe (JP.Image n m !v) = do+ guard (n * m /= V.length v)+ return $ fromVector Seq (m :. n) $ V.unsafeCast v+{-# INLINE fromJPImageUnsafe #-}+
+ src/Data/Massiv/Array/IO/Image/Netpbm.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Module : Data.Massiv.Array.IO.Image.Netpbm+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Data.Massiv.Array.IO.Image.Netpbm+ ( -- * Netpbm formats+ -- ** PBM+ PBM(..)+ -- ** PGM+ , PGM(..)+ -- ** PPM+ , PPM(..)+ ) where++import Control.Exception+import Control.Monad (guard)+import qualified Data.ByteString as B (ByteString)+import Data.Massiv.Array as M+import Data.Massiv.Array.IO.Base+import Data.Massiv.Array.IO.Image.JuicyPixels (toAnyCS)+import Data.Massiv.Array.Manifest.Vector+import Data.Typeable+import qualified Data.Vector.Storable as V+import Foreign.Storable (Storable)+import Graphics.ColorSpace+import Graphics.Netpbm as Netpbm hiding (PPM)+import qualified Graphics.Netpbm as Netpbm (PPM (..))+import Prelude as P++-- | Netpbm: portable bitmap image with @.pbm@ extension.+data PBM = PBM deriving Show++instance FileFormat PBM where+ ext _ = ".pbm"++instance FileFormat (Sequence PBM) where+ type WriteOptions (Sequence PBM) = WriteOptions PBM+ ext _ = ext PBM++instance FileFormat (Sequence (Auto PBM)) where+ type WriteOptions (Sequence (Auto PBM)) = WriteOptions PBM+ ext _ = ext PBM+++instance ColorSpace cs e => Readable PBM (Image S cs e) where+ decode f _ = decodePPM f fromNetpbmImage++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto PBM) (Image r cs e) where+ decode f _ = decodePPM f fromNetpbmImageAuto++instance ColorSpace cs e => Readable (Sequence PBM) (Array B Ix1 (Image S cs e)) where+ decode f _ = decodePPMs f fromNetpbmImage++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Sequence (Auto PBM)) (Array B Ix1 (Image r cs e)) where+ decode f _ = decodePPMs f fromNetpbmImageAuto++++-- | Netpbm: portable graymap image with @.pgm@ extension.+data PGM = PGM deriving Show++instance FileFormat PGM where+ ext _ = ".pgm"++instance FileFormat (Sequence PGM) where+ type WriteOptions (Sequence PGM) = WriteOptions PGM+ ext _ = ext PGM++instance FileFormat (Sequence (Auto PGM)) where+ type WriteOptions (Sequence (Auto PGM)) = WriteOptions PGM+ ext _ = ext PGM+++instance ColorSpace cs e => Readable PGM (Image S cs e) where+ decode f _ = decodePPM f fromNetpbmImage+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto PGM) (Image r cs e) where+ decode f _ = decodePPM f fromNetpbmImageAuto+++instance ColorSpace cs e => Readable (Sequence PGM) (Array B Ix1 (Image S cs e)) where+ decode f _ = decodePPMs f fromNetpbmImage+++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Sequence (Auto PGM)) (Array B Ix1 (Image r cs e)) where+ decode f _ = decodePPMs f fromNetpbmImageAuto+++-- | Netpbm: portable pixmap image with @.ppm@ extension.+data PPM = PPM deriving Show++instance FileFormat PPM where+ ext _ = ".ppm"++instance FileFormat (Sequence PPM) where+ type WriteOptions (Sequence PPM) = WriteOptions PPM+ ext _ = ext PPM++instance FileFormat (Sequence (Auto PPM)) where+ type WriteOptions (Sequence (Auto PPM)) = WriteOptions PPM+ ext _ = ext PPM+++instance ColorSpace cs e => Readable PPM (Image S cs e) where+ decode f _ = decodePPM f fromNetpbmImage++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Auto PPM) (Image r cs e) where+ decode f _ = decodePPM f fromNetpbmImageAuto++instance ColorSpace cs e => Readable (Sequence PPM) (Array B Ix1 (Image S cs e)) where+ decode f _ = decodePPMs f fromNetpbmImage++instance (Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ Readable (Sequence (Auto PPM)) (Array B Ix1 (Image r cs e)) where+ decode f _ = decodePPMs f fromNetpbmImageAuto++++decodePPMs :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ f+ -> (Netpbm.PPM -> Maybe (Image r cs e))+ -> B.ByteString+ -> Array B Ix1 (Image r cs e)+decodePPMs f converter bs =+ either (throw . DecodeError) (fromList Seq) $+ (P.map (fromEitherDecode f showNetpbmCS converter . Right) . fst) <$>+ parsePPM bs+{-# INLINE decodePPMs #-}+++decodePPM :: (FileFormat f, Mutable r Ix2 (Pixel cs e), ColorSpace cs e) =>+ f+ -> (Netpbm.PPM -> Maybe (Image r cs e))+ -> B.ByteString+ -> Image r cs e+decodePPM f decoder bs = fromEitherDecode f showNetpbmCS decoder $ do+ (ppms, _) <- parsePPM bs+ case ppms of+ [] -> Left "Cannot parse PNM image"+ (ppm:_) -> Right ppm+{-# INLINE decodePPM #-}+++-- | TODO: validate sizes+fromNetpbmImageUnsafe+ :: (Storable a, Storable (Pixel cs e))+ => (Int, Int) -> V.Vector a -> Maybe (Image S cs e)+fromNetpbmImageUnsafe (m, n) v = do+ guard (n * m /= V.length v)+ return $ fromVector Seq (m :. n) $ V.unsafeCast v++++showNetpbmCS :: Netpbm.PPM -> String+showNetpbmCS Netpbm.PPM {ppmData} = do+ case ppmData of+ PbmPixelData _ -> "Image S X Bit"+ PgmPixelData8 _ -> "Image S Y Word8"+ PgmPixelData16 _ -> "Image S Y Word16"+ PpmPixelDataRGB8 _ -> "Image S RGB Word8"+ PpmPixelDataRGB16 _ -> "Image S RGB Word16"+++fromNetpbmImage+ :: forall cs e . (ColorSpace cs e, V.Storable (Pixel cs e)) =>+ Netpbm.PPM -> Maybe (Image S cs e)+fromNetpbmImage Netpbm.PPM {..} = do+ let sz = (ppmHeight ppmHeader, ppmWidth ppmHeader)+ case ppmData of+ PbmPixelData v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel X Bit)+ fromNetpbmImageUnsafe sz v+ PgmPixelData8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word8)+ fromNetpbmImageUnsafe sz v+ PgmPixelData16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel Y Word16)+ fromNetpbmImageUnsafe sz v+ PpmPixelDataRGB8 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word8)+ fromNetpbmImageUnsafe sz v+ PpmPixelDataRGB16 v -> do Refl <- eqT :: Maybe (Pixel cs e :~: Pixel RGB Word16)+ fromNetpbmImageUnsafe sz v+++fromNetpbmImageAuto+ :: forall cs e r . (Mutable r Ix2 (Pixel cs e), ColorSpace cs e, V.Storable (Pixel cs e)) =>+ Netpbm.PPM -> Maybe (Image r cs e)+fromNetpbmImageAuto Netpbm.PPM {..} = do+ let sz = (ppmHeight ppmHeader, ppmWidth ppmHeader)+ case ppmData of+ PbmPixelData v ->+ (fromNetpbmImageUnsafe sz v :: Maybe (Image S X Bit)) >>= (toAnyCS . M.map fromPixelBinary)+ PgmPixelData8 v ->+ (fromNetpbmImageUnsafe sz v :: Maybe (Image S Y Word8)) >>= toAnyCS+ PgmPixelData16 v ->+ (fromNetpbmImageUnsafe sz v :: Maybe (Image S Y Word16)) >>= toAnyCS+ PpmPixelDataRGB8 v ->+ (fromNetpbmImageUnsafe sz v :: Maybe (Image S RGB Word8)) >>= toAnyCS+ PpmPixelDataRGB16 v ->+ (fromNetpbmImageUnsafe sz v :: Maybe (Image S RGB Word16)) >>= toAnyCS+
+ src/Graphics/ColorSpace.hs view
@@ -0,0 +1,726 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+#if __GLASGOW_HASKELL__ >= 800+ {-# OPTIONS_GHC -Wno-redundant-constraints #-}+ {-# LANGUAGE MonoLocalBinds #-}+#endif+-- |+-- Module : Graphics.ColorSpace+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace (+ -- * Pixels+ -- ** Family of Pixels+ -- | Pixel is a type family for all available color spaces. Below is the+ -- listed of all class instances, that 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+ -- <RGB:(255|0|0)>+ -- >>> PixelRGB 1 0 0 :: Pixel RGB Double -- Same red pixel in RGB with Double precision.+ -- <RGB:(1.0|0.0|0.0)>+ -- >>> (PixelRGB 255 0 0 :: Pixel RGB Word8) == (toWord8 <$> (PixelRGB 1 0 0 :: Pixel RGB Double))+ -- True+ --+ Pixel(..)+ , ColorSpace(..)+ , AlphaSpace(..)+ -- ** Luma (gray scale)+ -- | Conversion to Luma from other color spaces.+ , toPixelY+ , toPixelYA+ -- ** RGB+ -- | Conversion to RGB from other color spaces.+ , toPixelRGB+ , toPixelRGBA+ -- ** HSI+ -- | Conversion to HSI from other color spaces.+ , toPixelHSI+ , toPixelHSIA+ -- ** CMYK+ -- | Conversion to CMYK from other color spaces.+ , toPixelCMYK+ , toPixelCMYKA+ -- ** YCbCr+ -- | Conversion to YCbCr from other color spaces.+ , toPixelYCbCr+ , toPixelYCbCrA+ -- ** 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+ -- <Binary:(1)>+ -- >>> (on + on) * off -- equivalent to: (1 .|. 1) .&. 0+ -- <Binary:(0)>+ -- >>> (on + on) - on+ -- <Binary:(0)>+ --+ , toPixelBinary+ , fromPixelBinary+ , module Graphics.ColorSpace.Binary+ -- ** Complex+ , module Graphics.ColorSpace.Complex+ -- ** X+ , toPixelsX+ , fromPixelsX+ -- * 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,+ -- ** X+ X(..),+ -- * Precision+ -- ** Pixel+ Elevator,+ toWord8,+ toWord16,+ toWord32,+ toWord64,+ toFloat,+ toDouble,+ fromDouble,+ -- ** Componenet+ Word8, Word16, Word32, Word64+ ) where++import Data.Word+import Graphics.ColorSpace.Binary+import Graphics.ColorSpace.CMYK+import Graphics.ColorSpace.Complex+import Graphics.ColorSpace.HSI+import Graphics.ColorSpace.Internal+import Graphics.ColorSpace.RGB+import Graphics.ColorSpace.X+import Graphics.ColorSpace.Y+import Graphics.ColorSpace.YCbCr+++-- -- Binary:++-- | Convert to a `Binary` pixel.+toPixelBinary :: ColorSpace cs e => Pixel cs e -> Pixel X Bit+toPixelBinary px = if px == 0 then on else off+++-- | Convert a Binary pixel to Luma pixel+fromPixelBinary :: Pixel X Bit -> Pixel Y Word8+fromPixelBinary b = PixelY $ if isOn b then minBound else maxBound+{-# INLINE fromPixelBinary #-}+++-- | Check weather two Pixels are equal within a tolerance. Useful for comparing+-- pixels with `Float` or `Double` precision.+eqTolPx :: (ColorSpace cs e, Ord e) =>+ e -> Pixel cs e -> Pixel cs e -> Bool+eqTolPx !tol = foldlPx2 comp True+ where comp !acc !e1 !e2 = acc && max e1 e2 - min e1 e2 <= tol+ {-# INLINE comp #-}+{-# INLINE eqTolPx #-}++-- ToY++-- | 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+++instance Elevator e => ToY X e where+ toPixelY (PixelX y) = PixelY $ eToDouble y+ {-# INLINE toPixelY #-}++instance Elevator e => ToY Y e where+ toPixelY (PixelY y) = PixelY $ eToDouble y+ {-# INLINE toPixelY #-}++instance Elevator e => ToY YA e where+ toPixelY (PixelYA y _) = PixelY $ eToDouble y+ {-# INLINE toPixelY #-}++-- | Computes Luma: @ Y' = 0.299 * R' + 0.587 * G' + 0.114 * B' @+instance Elevator e => ToY RGB e where+ toPixelY (toDouble -> PixelRGB r g b) = PixelY (0.299*r + 0.587*g + 0.114*b)+ {-# INLINE toPixelY #-}++instance Elevator e => ToY RGBA e where+ toPixelY = toPixelY . dropAlpha+ {-# INLINE toPixelY #-}++instance Elevator e => ToY HSI e where+ toPixelY = toPixelY . toPixelRGB . toDouble+ {-# INLINE toPixelY #-}++instance Elevator e => ToY HSIA e where+ toPixelY = toPixelY . dropAlpha+ {-# INLINE toPixelY #-}++instance Elevator e => ToY CMYK e where+ toPixelY = toPixelY . toPixelRGB . toDouble+ {-# INLINE toPixelY #-}++instance Elevator e => ToY CMYKA e where+ toPixelY = toPixelY . toPixelRGB . toDouble . dropAlpha+ {-# INLINE toPixelY #-}++instance Elevator e => ToY YCbCr e where+ toPixelY (PixelYCbCr y _ _) = PixelY $ eToDouble y+ {-# INLINE toPixelY #-}++instance Elevator e => ToY YCbCrA e where+ toPixelY (PixelYCbCrA y _ _ _) = PixelY $ eToDouble 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 #-}+++instance ToYA X Bit where+ toPixelYA (PixelX y) = PixelYA (eToDouble y) 1+ {-# INLINE toPixelYA #-}+++instance ToY Y e => ToYA Y e++instance Elevator e => ToYA YA e where+ toPixelYA = toDouble+ {-# INLINE toPixelYA #-}++instance ToY RGB e => ToYA RGB e++instance Elevator e => ToYA RGBA e where+ toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))+ {-# INLINE toPixelYA #-}++instance ToY HSI e => ToYA HSI e++instance Elevator e => ToYA HSIA e where+ toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))+ {-# INLINE toPixelYA #-}++instance ToY CMYK e => ToYA CMYK e++instance Elevator e => ToYA CMYKA e where+ toPixelYA !px = addAlpha (eToDouble $ getAlpha px) (toPixelY (dropAlpha px))+ {-# INLINE toPixelYA #-}++instance ToY YCbCr e => ToYA YCbCr e++instance Elevator e => ToYA YCbCrA e where+ toPixelYA !px = addAlpha (eToDouble $ 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+++instance ToRGB X Bit where+ toPixelRGB (PixelX b) = promote $ eToDouble b+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB Y e where+ toPixelRGB (PixelY g) = promote $ eToDouble g+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB YA e where+ toPixelRGB = toPixelRGB . dropAlpha+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB RGB e where+ toPixelRGB = toDouble+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB RGBA e where+ toPixelRGB = toDouble . dropAlpha+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB HSI e where+ toPixelRGB (toDouble -> PixelHSI h' s i) = getRGB (h'*2*pi) where+ !is = i*s+ !second = i - is+ errorHue = error $ "HSI pixel is not properly scaled, Hue: " ++ show h'+ getFirst !a !b = i + is*cos a/cos b+ {-# INLINE getFirst #-}+ getThird !v1 !v2 = i + 2*is + v1 - v2+ {-# INLINE getThird #-}+ getRGB h+ | h < 0 = errorHue+ | h < 2*pi/3 = let !r = getFirst h (pi/3 - h)+ !b = second+ !g = getThird b r+ in PixelRGB r g b+ | h < 4*pi/3 = let !g = getFirst (h - 2*pi/3) (h + pi)+ !r = second+ !b = getThird r g+ in PixelRGB r g b+ | h < 2*pi = let !b = getFirst (h - 4*pi/3) (2*pi - pi/3 - h)+ !g = second+ !r = getThird g b+ in PixelRGB r g b+ | otherwise = errorHue+ {-# INLINE getRGB #-}+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB HSIA e where+ toPixelRGB = toPixelRGB . dropAlpha+ {-# INLINE toPixelRGB #-}+++instance Elevator e => ToRGB YCbCr e where+ toPixelRGB (toDouble -> PixelYCbCr y cb cr) = PixelRGB r g b where+ !r = clamp01 (y + 1.402*(cr - 0.5))+ !g = clamp01 (y - 0.34414*(cb - 0.5) - 0.71414*(cr - 0.5))+ !b = clamp01 (y + 1.772*(cb - 0.5))+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB YCbCrA e where+ toPixelRGB = toPixelRGB . dropAlpha+ {-# INLINE toPixelRGB #-}++instance Elevator e => ToRGB CMYK e where+ toPixelRGB (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 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 #-}+++instance ToRGBA X Bit++instance ToRGB Y e => ToRGBA Y e++instance Elevator e => ToRGBA YA e where+ toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))+ {-# INLINE toPixelRGBA #-}++instance ToRGB RGB e => ToRGBA RGB e++instance Elevator e => ToRGBA RGBA e where+ toPixelRGBA = toDouble+ {-# INLINE toPixelRGBA #-}++instance ToRGB HSI e => ToRGBA HSI e++instance Elevator e => ToRGBA HSIA e where+ toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))+ {-# INLINE toPixelRGBA #-}++instance ToRGB CMYK e => ToRGBA CMYK e++instance Elevator e => ToRGBA CMYKA e where+ toPixelRGBA !px = addAlpha (eToDouble $ getAlpha px) (toPixelRGB (dropAlpha px))+ {-# INLINE toPixelRGBA #-}++instance ToRGB YCbCr e => ToRGBA YCbCr e++instance Elevator e => ToRGBA YCbCrA e where+ toPixelRGBA !px = addAlpha (eToDouble $ 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+++instance Elevator e => ToHSI Y e where+ toPixelHSI (PixelY y) = PixelHSI 0 0 $ eToDouble y+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI YA e where+ toPixelHSI = toPixelHSI . dropAlpha+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI RGB e where+ toPixelHSI (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+ !i = (r + g + b) / 3+ !x = (2*r - g - b) / 2.449489742783178+ !y = (g - b) / 1.4142135623730951+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI RGBA e where+ toPixelHSI = toPixelHSI . dropAlpha+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI HSI e where+ toPixelHSI = toDouble+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI HSIA e where+ toPixelHSI = toPixelHSI . dropAlpha+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI YCbCr e where+ toPixelHSI = toPixelHSI . toPixelRGB+ {-# INLINE toPixelHSI #-}++instance Elevator e => ToHSI YCbCrA e where+ toPixelHSI = toPixelHSI . dropAlpha+ {-# INLINE toPixelHSI #-}++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 #-}+++instance ToHSI Y e => ToHSIA Y e++instance Elevator e => ToHSIA YA e where+ toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))+ {-# INLINE toPixelHSIA #-}++instance ToHSI RGB e => ToHSIA RGB e++instance Elevator e => ToHSIA RGBA e where+ toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))+ {-# INLINE toPixelHSIA #-}++instance ToHSI HSI e => ToHSIA HSI e++instance Elevator e => ToHSIA HSIA e where+ toPixelHSIA = toDouble+ {-# INLINE toPixelHSIA #-}++instance ToHSI CMYK e => ToHSIA CMYK e++instance Elevator e => ToHSIA CMYKA e where+ toPixelHSIA !px = addAlpha (eToDouble $ getAlpha px) (toPixelHSI (dropAlpha px))+ {-# INLINE toPixelHSIA #-}++instance ToHSI YCbCr e => ToHSIA YCbCr e++instance Elevator e => ToHSIA YCbCrA e where+ toPixelHSIA !px = addAlpha (eToDouble $ 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+++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 (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 Elevator e => ToCMYK RGBA e where+ toPixelCMYK = toPixelCMYK . dropAlpha+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK HSI e where+ toPixelCMYK = toPixelCMYK . toPixelRGB+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK HSIA e where+ toPixelCMYK = toPixelCMYK . dropAlpha+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK CMYK e where+ toPixelCMYK = toDouble+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK CMYKA e where+ toPixelCMYK = toPixelCMYK . dropAlpha+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK YCbCr e where+ toPixelCMYK = toPixelCMYK . toPixelRGB+ {-# INLINE toPixelCMYK #-}++instance Elevator e => ToCMYK YCbCrA e where+ toPixelCMYK = toPixelCMYK . dropAlpha+ {-# INLINE toPixelCMYK #-}+++-- ToCMYKA++-- | Conversion to `CMYKA`.+class ToCMYK cs e => ToCMYKA cs e where++ -- | Convert to a `CMYKA` pixel.+ toPixelCMYKA :: Pixel cs e -> Pixel CMYKA Double+ toPixelCMYKA = addAlpha 1 . toPixelCMYK+ {-# INLINE toPixelCMYKA #-}+++instance ToCMYK Y e => ToCMYKA Y e++instance Elevator e => ToCMYKA YA e where+ toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))+ {-# INLINE toPixelCMYKA #-}++instance ToCMYK RGB e => ToCMYKA RGB e++instance Elevator e => ToCMYKA RGBA e where+ toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))+ {-# INLINE toPixelCMYKA #-}++instance ToCMYK HSI e => ToCMYKA HSI e++instance Elevator e => ToCMYKA HSIA e where+ toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))+ {-# INLINE toPixelCMYKA #-}++instance ToCMYK CMYK e => ToCMYKA CMYK e++instance Elevator e => ToCMYKA CMYKA e where+ toPixelCMYKA = toDouble+ {-# INLINE toPixelCMYKA #-}++instance ToCMYK YCbCr e => ToCMYKA YCbCr e++instance Elevator e => ToCMYKA YCbCrA e where+ toPixelCMYKA !px = addAlpha (eToDouble $ getAlpha px) (toPixelCMYK (dropAlpha px))+ {-# INLINE toPixelCMYKA #-}+++++-- ToYCbCr++-- | Conversion to `YCbCr` color space.+class ColorSpace cs e => ToYCbCr cs e where++ -- | Convert to an `YCbCr` pixel.+ toPixelYCbCr :: Pixel cs e -> Pixel YCbCr Double++++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 e => ToYCbCr RGB e where+ toPixelYCbCr (toDouble -> PixelRGB r g b) = PixelYCbCr y cb cr where+ !y = clamp01 ( 0.299*r + 0.587*g + 0.114*b)+ !cb = clamp01 (0.5 - 0.168736*r - 0.331264*g + 0.5*b)+ !cr = clamp01 (0.5 + 0.5*r - 0.418688*g - 0.081312*b)+ {-# INLINE toPixelYCbCr #-}++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 e => ToYCbCr HSIA e where+ toPixelYCbCr = toPixelYCbCr . dropAlpha+ {-# INLINE toPixelYCbCr #-}++instance Elevator e => ToYCbCr YCbCr e where+ toPixelYCbCr = toDouble+ {-# INLINE toPixelYCbCr #-}++instance Elevator e => ToYCbCr YCbCrA e where+ toPixelYCbCr = toPixelYCbCr . dropAlpha+ {-# INLINE toPixelYCbCr #-}++instance Elevator e => ToYCbCr CMYK e where+ toPixelYCbCr = toPixelYCbCr . toPixelRGB+ {-# INLINE toPixelYCbCr #-}++instance Elevator e => ToYCbCr CMYKA e where+ toPixelYCbCr = toPixelYCbCr . dropAlpha+ {-# INLINE toPixelYCbCr #-}+++-- 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 #-}+++instance ToYCbCr Y e => ToYCbCrA Y e++instance Elevator e => ToYCbCrA YA e where+ toPixelYCbCrA !px = addAlpha (eToDouble $ 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 (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))+ {-# INLINE toPixelYCbCrA #-}++instance Elevator e => ToYCbCrA RGBA e where+ toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))+ {-# INLINE toPixelYCbCrA #-}++instance ToYCbCr CMYK e => ToYCbCrA CMYK e++instance Elevator e => ToYCbCrA CMYKA e where+ toPixelYCbCrA !px = addAlpha (eToDouble $ getAlpha px) (toPixelYCbCr (dropAlpha px))+ {-# INLINE toPixelYCbCrA #-}++instance ToYCbCr YCbCr e => ToYCbCrA YCbCr e++instance Elevator e => ToYCbCrA YCbCrA e where+ toPixelYCbCrA = toDouble+ {-# INLINE toPixelYCbCrA #-}+++-- | Change pixel precision to `Word8`.+toWord8 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word8+toWord8 = fmap eToWord8+{-# INLINABLE toWord8 #-}+++-- | Change pixel precision to `Word16`.+toWord16 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word16+toWord16 = fmap eToWord16+{-# INLINABLE toWord16 #-}+++-- | Change pixel precision to `Word32`.+toWord32 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word32+toWord32 = fmap eToWord32+{-# INLINABLE toWord32 #-}+++-- | Change pixel precision to `Word64`.+toWord64 :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Word64+toWord64 = fmap eToWord64+{-# INLINABLE toWord64 #-}+++-- | Change pixel precision to `Float`.+toFloat :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Float+toFloat = fmap eToFloat+{-# INLINABLE toFloat #-}+++-- | Change pixel precision to `Double`.+toDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs e -> Pixel cs Double+toDouble = fmap eToDouble+{-# INLINABLE toDouble #-}++++-- | Change pixel precision from `Double`.+fromDouble :: (Functor (Pixel cs), Elevator e) => Pixel cs Double -> Pixel cs e+fromDouble = fmap eFromDouble+{-# INLINABLE fromDouble #-}
+ src/Graphics/ColorSpace/Binary.hs view
@@ -0,0 +1,300 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.Binary+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.Binary (+ Bit(..), on, off, isOn, isOff, fromBool, zero, one, bit2bool, bool2bit, toNum, fromNum+ ) where++import Control.Monad+import Data.Bits+import Data.Typeable (Typeable)+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as M+import qualified Data.Vector.Unboxed as U+import Data.Word (Word8)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Graphics.ColorSpace.X+import Prelude hiding (map)+++-- | Under the hood, binary pixels are represented as `Word8`, but can only take+-- values of @0@ or @1@. Use `zero`\/`one` to construct a bit and `on`\/`off` to+-- construct a binary pixel.+newtype Bit = Bit Word8 deriving (Ord, Eq, Typeable)+++instance Show Bit where+ show (Bit 0) = "0"+ show _ = "1"+++instance Bits Bit where+ (Bit 0) .&. _ = Bit 0+ (Bit 1) .&. (Bit 1) = Bit 1+ _ .&. (Bit 0) = Bit 0+ _ .&. _ = Bit 1+ {-# INLINE (.&.) #-}+ (Bit 1) .|. _ = Bit 1+ (Bit 0) .|. (Bit 0) = Bit 0+ _ .|. _ = Bit 1+ {-# INLINE (.|.) #-}+ (Bit 0) `xor` (Bit 0) = Bit 0+ (Bit 1) `xor` (Bit 1) = Bit 0+ _ `xor` _ = Bit 1+ {-# INLINE xor #-}+ complement (Bit 0) = Bit 1+ complement _ = Bit 0+ {-# INLINE complement #-}+ shift !b 0 = b+ shift _ _ = Bit 0+ {-# INLINE shift #-}+ rotate !b _ = b+ {-# INLINE rotate #-}+ zeroBits = Bit 0+ {-# INLINE zeroBits #-}+ bit 0 = Bit 1+ bit _ = Bit 0+ {-# INLINE bit #-}+ testBit (Bit 1) 0 = True+ testBit _ _ = False+ {-# INLINE testBit #-}+ bitSizeMaybe _ = Just 1+ {-# INLINE bitSizeMaybe #-}+ bitSize _ = 1+ {-# INLINE bitSize #-}+ isSigned _ = False+ {-# INLINE isSigned #-}+ popCount (Bit 0) = 0+ popCount _ = 1+ {-# INLINE popCount #-}+++instance Bits (Pixel X Bit) where+ (.&.) = liftPx2 (.&.)+ {-# INLINE (.&.) #-}+ (.|.) = liftPx2 (.|.)+ {-# INLINE (.|.) #-}+ xor = liftPx2 xor+ {-# INLINE xor #-}+ complement = liftPx complement+ {-# INLINE complement #-}+ shift !b !n = liftPx (`shift` n) b+ {-# INLINE shift #-}+ rotate !b !n = liftPx (`rotate` n) b+ {-# INLINE rotate #-}+ zeroBits = promote zeroBits+ {-# INLINE zeroBits #-}+ bit = promote . bit+ {-# INLINE bit #-}+ testBit (PixelX (Bit 1)) 0 = True+ testBit _ _ = False+ {-# INLINE testBit #-}+ bitSizeMaybe _ = Just 1+ {-# INLINE bitSizeMaybe #-}+ bitSize _ = 1+ {-# INLINE bitSize #-}+ isSigned _ = False+ {-# INLINE isSigned #-}+ popCount (PixelX (Bit 0)) = 0+ popCount _ = 1+ {-# INLINE popCount #-}++toNum :: Num a => Bit -> a+toNum (Bit 0) = 0+toNum _ = 1+{-# INLINE toNum #-}++fromNum :: (Eq a, Num a) => a -> Bit+fromNum 0 = zero+fromNum _ = one+{-# INLINE fromNum #-}+++zero :: Bit+zero = Bit 0+{-# INLINE zero #-}++one :: Bit+one = Bit 1+{-# INLINE one #-}++bool2bit :: Bool -> Bit+bool2bit False = zero+bool2bit True = one+{-# INLINE bool2bit #-}++bit2bool :: Bit -> Bool+bit2bool (Bit 0) = False+bit2bool _ = True+{-# INLINE bit2bool #-}++-- | Represents value 'True' or @1@ in binary. Often also called a foreground+-- pixel of an object.+on :: Pixel X Bit+on = PixelX one+{-# INLINE on #-}+++-- | Represents value 'False' or @0@ in binary. Often also called a background+-- pixel.+off :: Pixel X Bit+off = PixelX zero+{-# INLINE off #-}+++-- | Convert a 'Bool' to a binary pixel.+--+-- >>> isOn (fromBool True)+-- True+--+fromBool :: Bool -> Pixel X Bit+fromBool False = off+fromBool True = on+{-# INLINE fromBool #-}+++-- | Test if Pixel's value is 'on'.+isOn :: Pixel X Bit -> Bool+isOn (PixelX (Bit 0)) = False+isOn _ = True+{-# INLINE isOn #-}+++-- | Test if Pixel's value is 'off'.+isOff :: Pixel X Bit -> Bool+isOff = not . isOn+{-# INLINE isOff #-}+++-- | Values: @0@ and @1@+instance Elevator Bit where+ eToWord8 (Bit 0) = 0+ eToWord8 _ = maxBound+ {-# INLINE eToWord8 #-}+ eToWord16 (Bit 0) = 0+ eToWord16 _ = maxBound+ {-# INLINE eToWord16 #-}+ eToWord32 (Bit 0) = 0+ eToWord32 _ = maxBound+ {-# INLINE eToWord32 #-}+ eToWord64 (Bit 0) = 0+ eToWord64 _ = maxBound+ {-# INLINE eToWord64 #-}+ eToFloat (Bit 0) = 0+ eToFloat _ = 1+ {-# INLINE eToFloat #-}+ eToDouble (Bit 0) = 0+ eToDouble _ = 1+ {-# INLINE eToDouble #-}+ eFromDouble 0 = Bit 0+ eFromDouble _ = Bit 1+ {-# INLINE eFromDouble #-}+++instance Num Bit where+ (+) = (.|.)+ {-# INLINE (+) #-}+ -- 0 - 0 = 0+ -- 0 - 1 = 0+ -- 1 - 0 = 1+ -- 1 - 1 = 0+ (Bit 0) - (Bit 0) = Bit 0+ _ - (Bit 0) = Bit 1+ _ - _ = Bit 0+ {-# INLINE (-) #-}+ (*) = (.&.)+ {-# INLINE (*) #-}+ abs = id+ {-# INLINE abs #-}+ signum = id+ {-# INLINE signum #-}+ fromInteger 0 = Bit 0+ fromInteger _ = Bit 1+ {-# INLINE fromInteger #-}+++instance Storable Bit where++ sizeOf _ = sizeOf (undefined :: Word8)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: Word8)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ b <- peek q+ return (Bit b)+ {-# INLINE peek #-}+ poke !p (Bit b) = do+ q <- return $ castPtr p+ poke q b+ {-# INLINE poke #-}+++-- | Unboxing of a `Bit`.+instance U.Unbox Bit++newtype instance U.MVector s Bit = MV_Bit (U.MVector s Word8)++instance M.MVector U.MVector Bit where+ basicLength (MV_Bit mvec) = M.basicLength mvec+ {-# INLINE basicLength #-}+ basicUnsafeSlice idx len (MV_Bit mvec) = MV_Bit (M.basicUnsafeSlice idx len mvec)+ {-# INLINE basicUnsafeSlice #-}+ basicOverlaps (MV_Bit mvec) (MV_Bit mvec') = M.basicOverlaps mvec mvec'+ {-# INLINE basicOverlaps #-}+ basicUnsafeNew len = MV_Bit `liftM` M.basicUnsafeNew len+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeReplicate len (Bit w) = MV_Bit `liftM` M.basicUnsafeReplicate len w+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeRead (MV_Bit mvec) idx = Bit `liftM` M.basicUnsafeRead mvec idx+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeWrite (MV_Bit mvec) idx (Bit w) = M.basicUnsafeWrite mvec idx w+ {-# INLINE basicUnsafeWrite #-}+ basicClear (MV_Bit mvec) = M.basicClear mvec+ {-# INLINE basicClear #-}+ basicSet (MV_Bit mvec) (Bit w) = M.basicSet mvec w+ {-# INLINE basicSet #-}+ basicUnsafeCopy (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeCopy mvec mvec'+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeMove (MV_Bit mvec) (MV_Bit mvec') = M.basicUnsafeMove mvec mvec'+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeGrow (MV_Bit mvec) len = MV_Bit `liftM` M.basicUnsafeGrow mvec len+ {-# INLINE basicUnsafeGrow #-}+#if MIN_VERSION_vector(0,11,0)+ basicInitialize (MV_Bit mvec) = M.basicInitialize mvec+ {-# INLINE basicInitialize #-}+#endif+++newtype instance U.Vector Bit = V_Bit (U.Vector Word8)++instance V.Vector U.Vector Bit where+ basicUnsafeFreeze (MV_Bit mvec) = V_Bit `liftM` V.basicUnsafeFreeze mvec+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeThaw (V_Bit vec) = MV_Bit `liftM` V.basicUnsafeThaw vec+ {-# INLINE basicUnsafeThaw #-}+ basicLength (V_Bit vec) = V.basicLength vec+ {-# INLINE basicLength #-}+ basicUnsafeSlice idx len (V_Bit vec) = V_Bit (V.basicUnsafeSlice idx len vec)+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeIndexM (V_Bit vec) idx = Bit `liftM` V.basicUnsafeIndexM vec idx+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeCopy (MV_Bit mvec) (V_Bit vec) = V.basicUnsafeCopy mvec vec+ {-# INLINE basicUnsafeCopy #-}+ elemseq (V_Bit vec) (Bit w) = V.elemseq vec w+ {-# INLINE elemseq #-}
+ src/Graphics/ColorSpace/CMYK.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.CMYK+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.CMYK (+ CMYK(..), CMYKA(..), Pixel(..)+ ) where++import Control.Applicative+import Data.Foldable+import Data.Typeable (Typeable)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Prelude hiding (map)++------------+--- CMYK ---+------------++-- | Cyan, Magenta, Yellow and Black color space.+data CMYK = CyanCMYK -- ^ Cyan+ | MagCMYK -- ^ Magenta+ | YelCMYK -- ^ Yellow+ | KeyCMYK -- ^ Key (Black)+ deriving (Eq, Enum, Show, Bounded, Typeable)+++instance Show e => Show (Pixel CMYK e) where+ show (PixelCMYK c m y k) = "<CMYK:("++show c++"|"++show m++"|"++show y++"|"++show k++")>"+++data instance Pixel CMYK e = PixelCMYK !e !e !e !e deriving Eq++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+ {-# INLINE fromComponents #-}+ toComponents (PixelCMYK c m y k) = (c, m, y, k)+ {-# INLINE toComponents #-}+ promote !e = PixelCMYK e e e e+ {-# INLINE promote #-}+ getPxC (PixelCMYK c _ _ _) CyanCMYK = c+ getPxC (PixelCMYK _ m _ _) MagCMYK = m+ getPxC (PixelCMYK _ _ y _) YelCMYK = y+ getPxC (PixelCMYK _ _ _ k) KeyCMYK = k+ {-# INLINE setPxC #-}+ setPxC (PixelCMYK _ m y k) CyanCMYK c = PixelCMYK c m y k+ setPxC (PixelCMYK c _ y k) MagCMYK m = PixelCMYK c m y k+ setPxC (PixelCMYK c m _ k) YelCMYK y = PixelCMYK c m y k+ setPxC (PixelCMYK c m y _) KeyCMYK k = PixelCMYK c m y k+ {-# INLINE getPxC #-}+ mapPxC f (PixelCMYK c m y k) =+ PixelCMYK (f CyanCMYK c) (f MagCMYK m) (f YelCMYK y) (f KeyCMYK k)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelCMYK c1 m1 y1 k1) (PixelCMYK c2 m2 y2 k2) =+ f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel CMYK) where+ fmap f (PixelCMYK c m y k) = PixelCMYK (f c) (f m) (f y) (f k)+ {-# INLINE fmap #-}+++instance Applicative (Pixel CMYK) where+ pure !e = PixelCMYK e e e e+ {-# INLINE pure #-}+ (PixelCMYK fc fm fy fk) <*> (PixelCMYK c m y k) = PixelCMYK (fc c) (fm m) (fy y) (fk k)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel CMYK) where+ foldr f !z (PixelCMYK c m y k) = f c (f m (f y (f k z)))+ {-# INLINE foldr #-}++++instance Storable e => Storable (Pixel CMYK e) where++ sizeOf _ = 4 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ let !q = castPtr p+ c <- peek q+ m <- peekElemOff q 1+ y <- peekElemOff q 2+ k <- peekElemOff q 3+ return (PixelCMYK c m y k)+ {-# INLINE peek #-}+ poke !p (PixelCMYK c m y k) = do+ let !q = castPtr p+ poke q c+ pokeElemOff q 1 m+ pokeElemOff q 2 y+ pokeElemOff q 3 k+ {-# INLINE poke #-}++-------------+--- CMYKA ---+-------------++-- | Cyan, Magenta, Yellow and Black color space with Alpha channel.+data CMYKA = CyanCMYKA -- ^ Cyan+ | MagCMYKA -- ^ Magenta+ | YelCMYKA -- ^ Yellow+ | KeyCMYKA -- ^ Key (Black)+ | AlphaCMYKA -- ^ Alpha+ deriving (Eq, Enum, Show, Bounded, Typeable)+++data instance Pixel CMYKA e = PixelCMYKA !e !e !e !e !e deriving Eq+++instance Show e => Show (Pixel CMYKA e) where+ show (PixelCMYKA c m y k a) =+ "<CMYKA:("++show c++"|"++show m++"|"++show y++"|"++show k++"|"++show a++")>"+++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+ {-# INLINE fromComponents #-}+ toComponents (PixelCMYKA c m y k a) = (c, m, y, k, a)+ {-# INLINE toComponents #-}+ promote !e = PixelCMYKA e e e e e+ {-# INLINE promote #-}+ getPxC (PixelCMYKA c _ _ _ _) CyanCMYKA = c+ getPxC (PixelCMYKA _ m _ _ _) MagCMYKA = m+ getPxC (PixelCMYKA _ _ y _ _) YelCMYKA = y+ getPxC (PixelCMYKA _ _ _ k _) KeyCMYKA = k+ getPxC (PixelCMYKA _ _ _ _ a) AlphaCMYKA = a+ {-# INLINE getPxC #-}+ setPxC (PixelCMYKA _ m y k a) CyanCMYKA c = PixelCMYKA c m y k a+ setPxC (PixelCMYKA c _ y k a) MagCMYKA m = PixelCMYKA c m y k a+ setPxC (PixelCMYKA c m _ k a) YelCMYKA y = PixelCMYKA c m y k a+ setPxC (PixelCMYKA c m y _ a) KeyCMYKA k = PixelCMYKA c m y k a+ setPxC (PixelCMYKA c m y k _) AlphaCMYKA a = PixelCMYKA c m y k a+ {-# INLINE setPxC #-}+ mapPxC f (PixelCMYKA c m y k a) =+ PixelCMYKA (f CyanCMYKA c) (f MagCMYKA m) (f YelCMYKA y) (f KeyCMYKA k) (f AlphaCMYKA a)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelCMYKA c1 m1 y1 k1 a1) (PixelCMYKA c2 m2 y2 k2 a2) =+ f (f (f (f (f z c1 c2) m1 m2) y1 y2) k1 k2) a1 a2+ {-# INLINE foldlPx2 #-}+++instance Elevator e => AlphaSpace CMYKA e where+ type Opaque CMYKA = CMYK++ getAlpha (PixelCMYKA _ _ _ _ a) = a+ {-# INLINE getAlpha #-}++ addAlpha !a (PixelCMYK c m y k) = PixelCMYKA c m y k a+ {-# INLINE addAlpha #-}++ dropAlpha (PixelCMYKA c m y k _) = PixelCMYK c m y k+ {-# INLINE dropAlpha #-}+++instance Functor (Pixel CMYKA) where+ fmap f (PixelCMYKA c m y k a) = PixelCMYKA (f c) (f m) (f y) (f k) (f a)+ {-# INLINE fmap #-}+++instance Applicative (Pixel CMYKA) where+ pure !e = PixelCMYKA e e e e e+ {-# INLINE pure #-}+ (PixelCMYKA fc fm fy fk fa) <*> (PixelCMYKA c m y k a) =+ PixelCMYKA (fc c) (fm m) (fy y) (fk k) (fa a)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel CMYKA) where+ foldr f !z (PixelCMYKA c m y k a) = f c (f m (f y (f k (f a z))))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel CMYKA e) where++ sizeOf _ = 5 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ c <- peek q+ m <- peekElemOff q 1+ y <- peekElemOff q 2+ k <- peekElemOff q 3+ a <- peekElemOff q 4+ return (PixelCMYKA c m y k a)+ {-# INLINE peek #-}+ poke !p (PixelCMYKA c m y k a) = do+ q <- return $ castPtr p+ poke q c+ pokeElemOff q 1 m+ pokeElemOff q 2 y+ pokeElemOff q 3 k+ pokeElemOff q 4 a+ {-# INLINE poke #-}
+ src/Graphics/ColorSpace/Complex.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+#if __GLASGOW_HASKELL__ >= 800+ {-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+-- |+-- Module : Graphics.ColorSpace.Complex+-- Copyright : (c) Alexey Kuleshevich 2016+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.Complex (+ -- *** Rectangular form+ Complex(..), (+:), realPart, imagPart,+ -- *** Polar form+ mkPolar, cis, polar, magnitude, phase,+ -- *** Conjugate+ conjugate+ ) where++import Control.Applicative+import Data.Complex (Complex (..))+import qualified Data.Complex as C hiding (Complex (..))+import Graphics.ColorSpace.Internal++++infix 6 +:++-- | Constrcut a complex pixel from two pixels representing real and imaginary parts.+--+-- @ PixelRGB 4 8 6 '+:' PixelRGB 7 1 1 __==__ PixelRGB (4 ':+' 7) (8 ':+' 1) (6 ':+' 1) @+--+(+:) :: Applicative (Pixel cs) => Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+(+:) = liftA2 (:+)+{-# INLINE (+:) #-}++-- | Extracts the real part of a complex pixel.+realPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+realPart = liftA C.realPart+{-# INLINE realPart #-}++-- | Extracts the imaginary part of a complex pixel.+imagPart :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+imagPart = liftA C.imagPart+{-# INLINE imagPart #-}++-- | Form a complex pixel from polar components of magnitude and phase.+mkPolar :: (Applicative (Pixel cs), RealFloat e) =>+ Pixel cs e -> Pixel cs e -> Pixel cs (Complex e)+mkPolar = liftA2 C.mkPolar+{-# INLINE mkPolar #-}++-- | @'cis' t@ is a complex pixel with magnitude 1 and phase t (modulo @2*'pi'@).+cis :: (Applicative (Pixel cs), RealFloat e) => Pixel cs e -> Pixel cs (Complex e)+cis = liftA C.cis+{-# INLINE cis #-}++-- | The function @'polar'@ takes a complex pixel and returns a (magnitude, phase)+-- pair of pixels in canonical form: the magnitude is nonnegative, and the phase+-- in the range @(-'pi', 'pi']@; if the magnitude is zero, then so is the phase.+polar :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> (Pixel cs e, Pixel cs e)+polar !zPx = (magnitude zPx, phase zPx)+{-# INLINE polar #-}++-- | The nonnegative magnitude of a complex pixel.+magnitude :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+magnitude = liftA C.magnitude+{-# INLINE magnitude #-}++-- | The phase of a complex pixel, in the range @(-'pi', 'pi']@. If the+-- magnitude is zero, then so is the phase.+phase :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs e+phase = liftA C.phase+{-# INLINE phase #-}++-- | The conjugate of a complex pixel.+conjugate :: (Applicative (Pixel cs), RealFloat e) => Pixel cs (Complex e) -> Pixel cs (Complex e)+conjugate = liftA C.conjugate+{-# INLINE conjugate #-}++
+ src/Graphics/ColorSpace/Elevator.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+#if __GLASGOW_HASKELL__ >= 800+ {-# OPTIONS_GHC -Wno-redundant-constraints #-}+#endif+-- |+-- Module : Graphics.ColorSpace.Elevator+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.Elevator (+ Elevator(..)+ , clamp01+ ) where++import qualified Data.Complex as C+import Data.Int+import Data.Typeable+import Data.Vector.Storable (Storable)+import Data.Vector.Unboxed (Unbox)+import Data.Word+import GHC.Float+++-- | 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+-- >>> eToWord8 <$> rgb+-- <RGB:(0|128|255)>+-- >>> eToWord16 <$> rgb+-- <RGB:(0|32768|65535)>+--+class (Eq e, Num e, Typeable e, Unbox e, Storable e) => Elevator e where++ -- | Values are scaled to @[0, 255]@ range.+ eToWord8 :: e -> Word8++ -- | Values are scaled to @[0, 65535]@ range.+ eToWord16 :: e -> Word16++ -- | Values are scaled to @[0, 4294967295]@ range.+ eToWord32 :: e -> Word32++ -- | Values are scaled to @[0, 18446744073709551615]@ range.+ eToWord64 :: e -> Word64++ -- | Values are scaled to @[0.0, 1.0]@ range.+ eToFloat :: e -> Float++ -- | Values are scaled to @[0.0, 1.0]@ range.+ eToDouble :: e -> Double++ -- | Values are scaled from @[0.0, 1.0]@ range.+ eFromDouble :: 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)+{-# INLINE stretch #-}+++-- | 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+ eToWord8 = id+ {-# INLINE eToWord8 #-}+ eToWord16 = raiseUp+ {-# INLINE eToWord16 #-}+ eToWord32 = raiseUp+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1+ {-# INLINE eToDouble #-}+ eFromDouble = eToWord8+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 65535]]@+instance Elevator Word16 where+ eToWord8 = dropDown+ {-# INLINE eToWord8 #-}+ eToWord16 = id+ {-# INLINE eToWord16 #-}+ eToWord32 = raiseUp+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1+ {-# INLINE eToDouble #-}+ eFromDouble = eToWord16+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 4294967295]@+instance Elevator Word32 where+ eToWord8 = dropDown+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown+ {-# INLINE eToWord16 #-}+ eToWord32 = id+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1+ {-# INLINE eToDouble #-}+ eFromDouble = eToWord32+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 18446744073709551615]@+instance Elevator Word64 where+ eToWord8 = dropDown+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown+ {-# INLINE eToWord16 #-}+ eToWord32 = dropDown+ {-# INLINE eToWord32 #-}+ eToWord64 = id+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1+ {-# INLINE eToDouble #-}+ eFromDouble = eToWord64+ {-# INLINE eFromDouble #-}++-- | Values between @[0, 18446744073709551615]@ on 64bit+instance Elevator Word where+ eToWord8 = dropDown+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown+ {-# INLINE eToWord16 #-}+ eToWord32 = dropDown+ {-# INLINE eToWord32 #-}+ eToWord64 = fromIntegral+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}++-- | Values between @[0, 127]@+instance Elevator Int8 where+ eToWord8 = fromIntegral . (max 0)+ {-# INLINE eToWord8 #-}+ eToWord16 = raiseUp . (max 0)+ {-# INLINE eToWord16 #-}+ eToWord32 = raiseUp . (max 0)+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp . (max 0)+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1 . (max 0)+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1 . (max 0)+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 32767]@+instance Elevator Int16 where+ eToWord8 = dropDown . (max 0)+ {-# INLINE eToWord8 #-}+ eToWord16 = fromIntegral . (max 0)+ {-# INLINE eToWord16 #-}+ eToWord32 = raiseUp . (max 0)+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp . (max 0)+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1 . (max 0)+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1 . (max 0)+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 2147483647]@+instance Elevator Int32 where+ eToWord8 = dropDown . (max 0)+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown . (max 0)+ {-# INLINE eToWord16 #-}+ eToWord32 = fromIntegral . (max 0)+ {-# INLINE eToWord32 #-}+ eToWord64 = raiseUp . (max 0)+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1 . (max 0)+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1 . (max 0)+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 9223372036854775807]@+instance Elevator Int64 where+ eToWord8 = dropDown . (max 0)+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown . (max 0)+ {-# INLINE eToWord16 #-}+ eToWord32 = dropDown . (max 0)+ {-# INLINE eToWord32 #-}+ eToWord64 = fromIntegral . (max 0)+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1 . (max 0)+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1 . (max 0)+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}+++-- | Values between @[0, 9223372036854775807]@ on 64bit+instance Elevator Int where+ eToWord8 = dropDown . (max 0)+ {-# INLINE eToWord8 #-}+ eToWord16 = dropDown . (max 0)+ {-# INLINE eToWord16 #-}+ eToWord32 = dropDown . (max 0)+ {-# INLINE eToWord32 #-}+ eToWord64 = fromIntegral . (max 0)+ {-# INLINE eToWord64 #-}+ eToFloat = squashTo1 . (max 0)+ {-# INLINE eToFloat #-}+ eToDouble = squashTo1 . (max 0)+ {-# INLINE eToDouble #-}+ eFromDouble = stretch . clamp01+ {-# INLINE eFromDouble #-}+++-- | Values between @[0.0, 1.0]@+instance Elevator Float where+ eToWord8 = stretch . clamp01+ {-# INLINE eToWord8 #-}+ eToWord16 = stretch . clamp01+ {-# INLINE eToWord16 #-}+ eToWord32 = stretch . clamp01+ {-# INLINE eToWord32 #-}+ eToWord64 = stretch . clamp01+ {-# INLINE eToWord64 #-}+ eToFloat = id+ {-# INLINE eToFloat #-}+ eToDouble = float2Double+ {-# INLINE eToDouble #-}+ eFromDouble = eToFloat+ {-# INLINE eFromDouble #-}+++-- | Values between @[0.0, 1.0]@+instance Elevator Double where+ eToWord8 = stretch . clamp01+ {-# INLINE eToWord8 #-}+ eToWord16 = stretch . clamp01+ {-# INLINE eToWord16 #-}+ eToWord32 = stretch . clamp01+ {-# INLINE eToWord32 #-}+ eToWord64 = stretch . clamp01+ {-# INLINE eToWord64 #-}+ eToFloat = double2Float+ {-# INLINE eToFloat #-}+ eToDouble = id+ {-# INLINE eToDouble #-}+ eFromDouble = id+ {-# INLINE eFromDouble #-}+++-- | Discards imaginary part and changes precision of real part.+instance (Num e, Elevator e, RealFloat e) => Elevator (C.Complex e) where+ eToWord8 = eToWord8 . C.realPart+ {-# INLINE eToWord8 #-}+ eToWord16 = eToWord16 . C.realPart+ {-# INLINE eToWord16 #-}+ eToWord32 = eToWord32 . C.realPart+ {-# INLINE eToWord32 #-}+ eToWord64 = eToWord64 . C.realPart+ {-# INLINE eToWord64 #-}+ eToFloat = eToFloat . C.realPart+ {-# INLINE eToFloat #-}+ eToDouble = eToDouble . C.realPart+ {-# INLINE eToDouble #-}+ eFromDouble = (C.:+ 0) . eFromDouble+ {-# INLINE eFromDouble #-}
+ src/Graphics/ColorSpace/HSI.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.HSI+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.HSI (+ HSI(..), HSIA(..), Pixel(..)+ ) where++import Control.Applicative+import Data.Foldable+import Data.Typeable (Typeable)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Prelude hiding (map)++-----------+--- HSI ---+-----------++-- | Hue, Saturation and Intensity color space.+data HSI = HueHSI -- ^ Hue+ | SatHSI -- ^ Saturation+ | IntHSI -- ^ Intensity+ deriving (Eq, Enum, Show, Bounded, Typeable)++data instance Pixel HSI e = PixelHSI !e !e !e deriving Eq+++instance Show e => Show (Pixel HSI e) where+ show (PixelHSI h s i) = "<HSI:("++show h++"|"++show s++"|"++show i++")>"+++instance Elevator e => ColorSpace HSI e where+ type Components HSI e = (e, e, e)++ toComponents (PixelHSI h s i) = (h, s, i)+ {-# INLINE toComponents #-}+ fromComponents !(h, s, i) = PixelHSI h s i+ {-# INLINE fromComponents #-}+ promote = pure+ {-# INLINE promote #-}+ getPxC (PixelHSI h _ _) HueHSI = h+ getPxC (PixelHSI _ s _) SatHSI = s+ getPxC (PixelHSI _ _ i) IntHSI = i+ {-# INLINE getPxC #-}+ setPxC (PixelHSI _ s i) HueHSI h = PixelHSI h s i+ setPxC (PixelHSI h _ i) SatHSI s = PixelHSI h s i+ setPxC (PixelHSI h s _) IntHSI i = PixelHSI h s i+ {-# INLINE setPxC #-}+ mapPxC f (PixelHSI h s i) = PixelHSI (f HueHSI h) (f SatHSI s) (f IntHSI i)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelHSI h1 s1 i1) (PixelHSI h2 s2 i2) =+ f (f (f z h1 h2) s1 s2) i1 i2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel HSI) where+ fmap f (PixelHSI h s i) = PixelHSI (f h) (f s) (f i)+ {-# INLINE fmap #-}+++instance Applicative (Pixel HSI) where+ pure !e = PixelHSI e e e+ {-# INLINE pure #-}+ (PixelHSI fh fs fi) <*> (PixelHSI h s i) = PixelHSI (fh h) (fs s) (fi i)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel HSI) where+ foldr f !z (PixelHSI h s i) = f h (f s (f i z))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel HSI e) where++ sizeOf _ = 3 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ r <- peek q+ g <- peekElemOff q 1+ b <- peekElemOff q 2+ return (PixelHSI r g b)+ {-# INLINE peek #-}+ poke !p (PixelHSI r g b) = do+ q <- return $ castPtr p+ poke q r+ pokeElemOff q 1 g+ pokeElemOff q 2 b+ {-# INLINE poke #-}++------------+--- HSIA ---+------------++-- | Hue, Saturation and Intensity color space with Alpha channel.+data HSIA = HueHSIA -- ^ Hue+ | SatHSIA -- ^ Saturation+ | IntHSIA -- ^ Intensity+ | AlphaHSIA -- ^ Alpha+ deriving (Eq, Enum, Show, Bounded, Typeable)+++data instance Pixel HSIA e = PixelHSIA !e !e !e !e deriving Eq+++instance Show e => Show (Pixel HSIA e) where+ show (PixelHSIA h s i a) = "<HSIA:("++show h++"|"++show s++"|"++show i++"|"++show a++")>"+++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)+ {-# INLINE toComponents #-}+ fromComponents !(h, s, i, a) = PixelHSIA h s i a+ {-# INLINE fromComponents #-}+ promote = pure+ {-# INLINE promote #-}+ getPxC (PixelHSIA h _ _ _) HueHSIA = h+ getPxC (PixelHSIA _ s _ _) SatHSIA = s+ getPxC (PixelHSIA _ _ i _) IntHSIA = i+ getPxC (PixelHSIA _ _ _ a) AlphaHSIA = a+ {-# INLINE getPxC #-}+ setPxC (PixelHSIA _ s i a) HueHSIA h = PixelHSIA h s i a+ setPxC (PixelHSIA h _ i a) SatHSIA s = PixelHSIA h s i a+ setPxC (PixelHSIA h s _ a) IntHSIA i = PixelHSIA h s i a+ setPxC (PixelHSIA h s i _) AlphaHSIA a = PixelHSIA h s i a+ {-# INLINE setPxC #-}+ mapPxC f (PixelHSIA h s i a) =+ PixelHSIA (f HueHSIA h) (f SatHSIA s) (f IntHSIA i) (f AlphaHSIA a)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelHSIA h1 s1 i1 a1) (PixelHSIA h2 s2 i2 a2) =+ f (f (f (f z h1 h2) s1 s2) i1 i2) a1 a2+ {-# INLINE foldlPx2 #-}+++instance Elevator e => AlphaSpace HSIA e where+ type Opaque HSIA = HSI++ getAlpha (PixelHSIA _ _ _ a) = a+ {-# INLINE getAlpha #-}+ addAlpha !a (PixelHSI h s i) = PixelHSIA h s i a+ {-# INLINE addAlpha #-}+ dropAlpha (PixelHSIA h s i _) = PixelHSI h s i+ {-# INLINE dropAlpha #-}+++instance Functor (Pixel HSIA) where+ fmap f (PixelHSIA h s i a) = PixelHSIA (f h) (f s) (f i) (f a)+ {-# INLINE fmap #-}+++instance Applicative (Pixel HSIA) where+ pure !e = PixelHSIA e e e e+ {-# INLINE pure #-}+ (PixelHSIA fh fs fi fa) <*> (PixelHSIA h s i a) = PixelHSIA (fh h) (fs s) (fi i) (fa a)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel HSIA) where+ foldr f !z (PixelHSIA h s i a) = f h (f s (f i (f a z)))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel HSIA e) where+ sizeOf _ = 4 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ h <- peek q+ s <- peekElemOff q 1+ i <- peekElemOff q 2+ a <- peekElemOff q 3+ return (PixelHSIA h s i a)+ {-# INLINE peek #-}+ poke !p (PixelHSIA h s i a) = do+ q <- return $ castPtr p+ poke q h+ pokeElemOff q 1 s+ pokeElemOff q 2 i+ pokeElemOff q 3 a+ {-# INLINE poke #-}
+ src/Graphics/ColorSpace/Internal.hs view
@@ -0,0 +1,236 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.Internal+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.Internal+ ( Pixel+ , ColorSpace(..)+ , AlphaSpace(..)+ , module Graphics.ColorSpace.Elevator+ ) where++import Control.DeepSeq (NFData (rnf), deepseq)+import Control.Monad (liftM)+import Data.Default+import Data.Foldable+import Data.Maybe (fromMaybe)+import Data.Typeable+import qualified Data.Vector.Generic as V+import qualified Data.Vector.Generic.Mutable as VM+import qualified Data.Vector.Storable as VS+import qualified Data.Vector.Unboxed as VU+import Graphics.ColorSpace.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,+ Eq (Pixel cs e), VU.Unbox (Components cs e), VS.Storable (Pixel cs e), Elevator e)+ => ColorSpace cs e where++ type Components cs e++ -- | Convert a Pixel to a representation suitable for storage as an unboxed+ -- element, usually a tuple of channels.+ toComponents :: Pixel cs e -> Components cs e++ -- | Convert from an elemnt representation back to a Pixel.+ fromComponents :: Components cs e -> Pixel cs e++ -- | Construt a Pixel by replicating the same value across all of the components.+ promote :: e -> Pixel cs e++ -- | Retrieve Pixel's component value+ getPxC :: Pixel cs e -> cs -> e++ -- | Set Pixel's component value+ setPxC :: Pixel cs e -> cs -> e -> Pixel cs e++ -- | Map a channel aware function over all Pixel's components.+ mapPxC :: (cs -> e -> e) -> Pixel cs e -> Pixel cs e++ -- | Map a function over all Pixel's componenets.+ liftPx :: (e -> e) -> Pixel cs e -> Pixel cs e++ -- | Zip two Pixels with a function.+ liftPx2 :: (e -> e -> e) -> Pixel cs e -> Pixel cs e -> Pixel cs e++ -- | Left fold on two pixels a the same time.+ foldlPx2 :: (b -> e -> e -> b) -> b -> Pixel cs e -> Pixel cs e -> b++ -- | Right fold over all Pixel's components.+ foldrPx :: (e -> b -> b) -> b -> Pixel cs e -> b+ foldrPx f !z0 !xs = foldlPx f' id xs z0+ where f' k x !z = k $! f x z++ -- | Left strict fold over all Pixel's components.+ foldlPx :: (b -> e -> b) -> b -> Pixel cs e -> b+ foldlPx f !z0 !xs = foldrPx f' id xs z0+ where f' x k !z = k $! f z x++ foldl1Px :: (e -> e -> e) -> Pixel cs e -> e+ foldl1Px f !xs = fromMaybe (error "foldl1Px: empty Pixel")+ (foldlPx mf Nothing xs)+ where+ mf m !y = Just (case m of+ Nothing -> y+ Just x -> f x y)+ toListPx :: Pixel cs e -> [e]+ toListPx !px = foldr' f [] (enumFrom (toEnum 0))+ where f !cs !ls = getPxC px cs:ls+++-- | A color space that supports transparency.+class (ColorSpace (Opaque cs) e, ColorSpace cs e) => AlphaSpace cs e where+ -- | A corresponding opaque version of this color space.+ type Opaque cs++ -- | Get an alpha channel of a transparant pixel.+ getAlpha :: Pixel cs e -> e++ -- | 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++ -- | Convert a transparent pixel to an opaque one by dropping the alpha+ -- channel.+ --+ -- @ dropAlpha (PixelRGBA 1 2 3 4) == PixelRGB 1 2 3 @+ --+ dropAlpha :: Pixel cs e -> Pixel (Opaque cs) e++instance ColorSpace cs e => Default (Pixel cs e) where++ def = promote 0+ {-# INLINE def #-}+++instance ColorSpace cs e => Num (Pixel cs e) where+ (+) = liftPx2 (+)+ {-# INLINE (+) #-}+ (-) = liftPx2 (-)+ {-# INLINE (-) #-}+ (*) = liftPx2 (*)+ {-# INLINE (*) #-}+ abs = liftPx abs+ {-# INLINE abs #-}+ signum = liftPx signum+ {-# INLINE signum #-}+ fromInteger = promote . fromInteger+ {-# INLINE fromInteger #-}+++instance (ColorSpace cs e, Fractional e) => Fractional (Pixel cs e) where+ (/) = liftPx2 (/)+ {-# INLINE (/) #-}+ recip = liftPx recip+ {-# INLINE recip #-}+ fromRational = promote . fromRational+ {-# INLINE fromRational #-}+++instance (ColorSpace cs e, Floating e) => Floating (Pixel cs e) 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 (ColorSpace cs e, Bounded e) => Bounded (Pixel cs e) where+ maxBound = promote maxBound+ {-# INLINE maxBound #-}+ minBound = promote minBound+ {-# INLINE minBound #-}++instance (ColorSpace cs e, NFData e) => NFData (Pixel cs e) where++ rnf = foldrPx deepseq ()+ {-# INLINE rnf #-}+++-- | Unboxing of a `Pixel`.+instance ColorSpace cs e => VU.Unbox (Pixel cs e)++newtype instance VU.MVector s (Pixel cs e) = MV_Pixel (VU.MVector s (Components cs e))++instance ColorSpace cs e => VM.MVector VU.MVector (Pixel cs e) where+ basicLength (MV_Pixel mvec) = VM.basicLength mvec+ {-# INLINE basicLength #-}+ basicUnsafeSlice idx len (MV_Pixel mvec) = MV_Pixel (VM.basicUnsafeSlice idx len mvec)+ {-# INLINE basicUnsafeSlice #-}+ basicOverlaps (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicOverlaps mvec mvec'+ {-# INLINE basicOverlaps #-}+ basicUnsafeNew len = MV_Pixel `liftM` VM.basicUnsafeNew len+ {-# INLINE basicUnsafeNew #-}+ basicUnsafeReplicate len val = MV_Pixel `liftM` VM.basicUnsafeReplicate len (toComponents val)+ {-# INLINE basicUnsafeReplicate #-}+ basicUnsafeRead (MV_Pixel mvec) idx = fromComponents `liftM` VM.basicUnsafeRead mvec idx+ {-# INLINE basicUnsafeRead #-}+ basicUnsafeWrite (MV_Pixel mvec) idx val = VM.basicUnsafeWrite mvec idx (toComponents val)+ {-# INLINE basicUnsafeWrite #-}+ basicClear (MV_Pixel mvec) = VM.basicClear mvec+ {-# INLINE basicClear #-}+ basicSet (MV_Pixel mvec) val = VM.basicSet mvec (toComponents val)+ {-# INLINE basicSet #-}+ basicUnsafeCopy (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeCopy mvec mvec'+ {-# INLINE basicUnsafeCopy #-}+ basicUnsafeMove (MV_Pixel mvec) (MV_Pixel mvec') = VM.basicUnsafeMove mvec mvec'+ {-# INLINE basicUnsafeMove #-}+ basicUnsafeGrow (MV_Pixel mvec) len = MV_Pixel `liftM` VM.basicUnsafeGrow mvec len+ {-# INLINE basicUnsafeGrow #-}+#if MIN_VERSION_vector(0,11,0)+ basicInitialize (MV_Pixel mvec) = VM.basicInitialize mvec+ {-# INLINE basicInitialize #-}+#endif+++newtype instance VU.Vector (Pixel cs e) = V_Pixel (VU.Vector (Components cs e))++instance (ColorSpace cs e) => V.Vector VU.Vector (Pixel cs e) where+ basicUnsafeFreeze (MV_Pixel mvec) = V_Pixel `liftM` V.basicUnsafeFreeze mvec+ {-# INLINE basicUnsafeFreeze #-}+ basicUnsafeThaw (V_Pixel vec) = MV_Pixel `liftM` V.basicUnsafeThaw vec+ {-# INLINE basicUnsafeThaw #-}+ basicLength (V_Pixel vec) = V.basicLength vec+ {-# INLINE basicLength #-}+ basicUnsafeSlice idx len (V_Pixel vec) = V_Pixel (V.basicUnsafeSlice idx len vec)+ {-# INLINE basicUnsafeSlice #-}+ basicUnsafeIndexM (V_Pixel vec) idx = fromComponents `liftM` V.basicUnsafeIndexM vec idx+ {-# INLINE basicUnsafeIndexM #-}+ basicUnsafeCopy (MV_Pixel mvec) (V_Pixel vec) = V.basicUnsafeCopy mvec vec+ {-# INLINE basicUnsafeCopy #-}+ elemseq (V_Pixel vec) val = V.elemseq vec (toComponents val)+ {-# INLINE elemseq #-}
+ src/Graphics/ColorSpace/RGB.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.RGB+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.RGB (+ RGB(..), RGBA(..), Pixel(..)+ ) where++import Prelude hiding (map)+import Control.Applicative+import Foreign.Ptr+import Foreign.Storable+import Data.Foldable+import Data.Typeable (Typeable)+import Graphics.ColorSpace.Internal++-----------+--- RGB ---+-----------++-- | Red, Green and Blue color space.+data RGB = RedRGB+ | GreenRGB+ | BlueRGB deriving (Eq, Enum, Show, Bounded, Typeable)+++data instance Pixel RGB e = PixelRGB !e !e !e deriving Eq++instance Show e => Show (Pixel RGB e) where+ show (PixelRGB r g b) = "<RGB:("++show r++"|"++show g++"|"++show b++")>"+++instance Elevator e => ColorSpace RGB e where+ type Components RGB e = (e, e, e)++ toComponents (PixelRGB r g b) = (r, g, b)+ {-# INLINE toComponents #-}+ fromComponents !(r, g, b) = PixelRGB r g b+ {-# INLINE fromComponents #-}+ promote = pure+ {-# INLINE promote #-}+ getPxC (PixelRGB r _ _) RedRGB = r+ getPxC (PixelRGB _ g _) GreenRGB = g+ getPxC (PixelRGB _ _ b) BlueRGB = b+ {-# INLINE getPxC #-}+ setPxC (PixelRGB _ g b) RedRGB r = PixelRGB r g b+ setPxC (PixelRGB r _ b) GreenRGB g = PixelRGB r g b+ setPxC (PixelRGB r g _) BlueRGB b = PixelRGB r g b+ {-# INLINE setPxC #-}+ mapPxC f (PixelRGB r g b) = PixelRGB (f RedRGB r) (f GreenRGB g) (f BlueRGB b)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelRGB r1 g1 b1) (PixelRGB r2 g2 b2) =+ f (f (f z r1 r2) g1 g2) b1 b2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel RGB) where+ fmap f (PixelRGB r g b) = PixelRGB (f r) (f g) (f b)+ {-# INLINE fmap #-}+++instance Applicative (Pixel RGB) where+ pure !e = PixelRGB e e e+ {-# INLINE pure #-}+ (PixelRGB fr fg fb) <*> (PixelRGB r g b) = PixelRGB (fr r) (fg g) (fb b)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel RGB) where+ foldr f !z (PixelRGB r g b) = f r (f g (f b z))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel RGB e) where+ sizeOf _ = 3 * sizeOf (undefined :: e)+ alignment _ = alignment (undefined :: e)+ peek !p = do+ let !q = castPtr p+ r <- peek q+ g <- peekElemOff q 1+ b <- peekElemOff q 2+ return (PixelRGB r g b)+ poke !p (PixelRGB r g b) = do+ let !q = castPtr p+ poke q r+ pokeElemOff q 1 g+ pokeElemOff q 2 b+++------------+--- RGBA ---+------------+++-- | Red, Green and Blue color space with Alpha channel.+data RGBA = RedRGBA+ | GreenRGBA+ | BlueRGBA+ | AlphaRGBA deriving (Eq, Enum, Show, Bounded, Typeable)++data instance Pixel RGBA e = PixelRGBA !e !e !e !e deriving Eq+++instance Show e => Show (Pixel RGBA e) where+ show (PixelRGBA r g b a) = "<RGBA:("++show r++"|"++show g++"|"++show b++"|"++show a++")>"+++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)+ {-# INLINE toComponents #-}+ fromComponents !(r, g, b, a) = PixelRGBA r g b a+ {-# INLINE fromComponents #-}+ promote = pure+ {-# INLINE promote #-}+ getPxC (PixelRGBA r _ _ _) RedRGBA = r+ getPxC (PixelRGBA _ g _ _) GreenRGBA = g+ getPxC (PixelRGBA _ _ b _) BlueRGBA = b+ getPxC (PixelRGBA _ _ _ a) AlphaRGBA = a+ {-# INLINE getPxC #-}+ setPxC (PixelRGBA _ g b a) RedRGBA r = PixelRGBA r g b a+ setPxC (PixelRGBA r _ b a) GreenRGBA g = PixelRGBA r g b a+ setPxC (PixelRGBA r g _ a) BlueRGBA b = PixelRGBA r g b a+ setPxC (PixelRGBA r g b _) AlphaRGBA a = PixelRGBA r g b a+ {-# INLINE setPxC #-}+ mapPxC f (PixelRGBA r g b a) =+ PixelRGBA (f RedRGBA r) (f GreenRGBA g) (f BlueRGBA b) (f AlphaRGBA a)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelRGBA r1 g1 b1 a1) (PixelRGBA r2 g2 b2 a2) =+ f (f (f (f z r1 r2) g1 g2) b1 b2) a1 a2+ {-# INLINE foldlPx2 #-}+++instance Elevator e => AlphaSpace RGBA e where+ type Opaque RGBA = RGB++ getAlpha (PixelRGBA _ _ _ a) = a+ {-# INLINE getAlpha #-}+ addAlpha !a (PixelRGB r g b) = PixelRGBA r g b a+ {-# INLINE addAlpha #-}+ dropAlpha (PixelRGBA r g b _) = PixelRGB r g b+ {-# 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 #-}++instance Applicative (Pixel RGBA) where+ pure !e = PixelRGBA e e e e+ {-# INLINE pure #-}+ (PixelRGBA fr fg fb fa) <*> (PixelRGBA r g b a) = PixelRGBA (fr r) (fg g) (fb b) (fa a)+ {-# INLINE (<*>) #-}++instance Foldable (Pixel RGBA) where+ 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 _ = 4 * sizeOf (undefined :: e)+ alignment _ = alignment (undefined :: e)+ peek p = do+ q <- return $ castPtr p+ r <- peek q+ g <- peekElemOff q 1+ b <- peekElemOff q 2+ a <- peekElemOff q 3+ return (PixelRGBA r g b a)+ poke p (PixelRGBA r g b a) = do+ q <- return $ castPtr p+ poke q r+ pokeElemOff q 1 g+ pokeElemOff q 2 b+ pokeElemOff q 3 a
+ src/Graphics/ColorSpace/X.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.X+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.X+ ( X(..)+ , Pixel(..)+ , toPixelsX+ , fromPixelsX+ ) where++import Control.Applicative+import Data.Foldable+import Data.Typeable (Typeable)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Prelude as P++-- ^ This is a single channel colorspace, that is designed to separate Gray+-- level values from other types of colorspace, hence it is not convertible to+-- or from, but rather is here to allow operation on arbirtary single channel+-- images. If you are looking for a true grayscale colorspace+-- 'Graphics.ColorSpace.Luma.Y' should be used instead.+data X = X deriving (Eq, Enum, Bounded, Show, Typeable)+++newtype instance Pixel X e = PixelX { getX :: e } deriving (Ord, Eq)+++instance Show e => Show (Pixel X e) where+ show (PixelX g) = "<X:("++show g++")>"+++instance Elevator e => ColorSpace X e where+ type Components X e = e++ promote = PixelX+ {-# INLINE promote #-}+ fromComponents = PixelX+ {-# INLINE fromComponents #-}+ toComponents (PixelX g) = g+ {-# INLINE toComponents #-}+ getPxC (PixelX g) X = g+ {-# INLINE getPxC #-}+ setPxC (PixelX _) X g = PixelX g+ {-# INLINE setPxC #-}+ mapPxC f (PixelX g) = PixelX (f X g)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelX g1) (PixelX g2) = f z g1 g2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel X) where+ fmap f (PixelX g) = PixelX (f g)+ {-# INLINE fmap #-}+++instance Applicative (Pixel X) where+ pure = PixelX+ {-# INLINE pure #-}+ (PixelX fg) <*> (PixelX g) = PixelX (fg g)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel X) where+ foldr f !z (PixelX g) = f g z+ {-# INLINE foldr #-}+++instance Monad (Pixel X) where++ return = PixelX+ {-# INLINE return #-}++ (>>=) (PixelX g) f = f g+ {-# INLINE (>>=) #-}+++instance Storable e => Storable (Pixel X e) where++ sizeOf _ = sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ g <- peek q+ return (PixelX g)+ {-# INLINE peek #-}+ poke !p (PixelX g) = do+ q <- return $ castPtr p+ poke q g+ {-# INLINE poke #-}+++-- | Separate a Pixel into a list of components with 'X' pixels containing every+-- component from the pixel.+--+-- >>> toPixelsX (PixelRGB 4 5 6)+-- [<X:(4)>,<X:(5)>,<X:(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)]+-- <RGB:(3.0|4.0|5.0)>+-- >>> fromPixelsX $ zip (enumFrom RedRGB) (toPixelsX $ PixelRGB 4 5 6)+-- <RGB:(4.0|5.0|6.0)>+--+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++++-- -- | Apply a left fold to each of the pixels in the image.+-- squashWith :: (Array arr cs e, Array arr X b) =>+-- (b -> e -> b) -> b -> Image arr cs e -> Image arr X b+-- squashWith f !a = I.map (PixelX . foldlPx f a) where+-- {-# INLINE squashWith #-}+++-- -- | Combination of zipWith and simultanious left fold on two pixels at the same time.+-- squashWith2 :: (Array arr cs e, Array arr X b) =>+-- (b -> e -> e -> b) -> b -> Image arr cs e -> Image arr cs e -> Image arr X b+-- squashWith2 f !a = I.zipWith (PixelX .:! foldlPx2 f a) where+-- {-# INLINE squashWith2 #-}+++-- -- | Separate an image into a list of images with 'X' pixels containing every+-- -- channel from the source image.+-- --+-- -- >>> frog <- readImageRGB "images/frog.jpg"+-- -- >>> let [frog_red, frog_green, frog_blue] = toImagesX frog+-- -- >>> writeImage "images/frog_red.png" $ toImageY frog_red+-- -- >>> writeImage "images/frog_green.jpg" $ toImageY frog_green+-- -- >>> writeImage "images/frog_blue.jpg" $ toImageY frog_blue+-- --+-- -- <<images/frog_red.jpg>> <<images/frog_green.jpg>> <<images/frog_blue.jpg>>+-- --+-- toImagesX :: (Array arr cs e, Array arr X e) => Image arr cs e -> [Image arr X e]+-- toImagesX !img = P.map getCh (enumFrom minBound) where+-- getCh !ch = I.map (PixelX . (`getPxC` ch)) img+-- {-# INLINE getCh #-}+-- {-# INLINE toImagesX #-}+++-- -- | Combine a list of images with 'X' pixels into an image of any color+-- -- space, by supplying an order of color space channels.+-- --+-- -- For example here is a frog with swapped 'BlueRGB' and 'GreenRGB' channels.+-- --+-- -- >>> writeImage "images/frog_rbg.jpg" $ fromImagesX [(RedRGB, frog_red), (BlueRGB, frog_green), (GreenRGB, frog_blue)]+-- --+-- -- <<images/frog.jpg>> <<images/frog_rbg.jpg>>+-- --+-- -- It is worth noting though, despite that separating image channels can be+-- -- sometimes pretty useful, exactly the same effect as in example above can be+-- -- achieved in a much simpler and a more efficient way:+-- --+-- -- @ `I.map` (\\(PixelRGB r g b) -> PixelRGB r b g) frog @+-- --+-- 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+-- {-# INLINE updateCh #-}+-- fromXs img [] = img+-- fromXs img ((c, i):xs) = fromXs (I.zipWith (updateCh c) img i) xs+-- {-# INLINE fromXs #-}+-- {-# INLINE fromImagesX #-}
+ src/Graphics/ColorSpace/Y.hs view
@@ -0,0 +1,196 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.Y+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.Y (+ Y(..), YA(..), Pixel(..)+ ) where++import Control.Applicative+import Data.Foldable+import Data.Typeable (Typeable)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Prelude hiding (map)++---------+--- Y ---+---------++-- | Luma or brightness, which is usually denoted as @Y'@.+data Y = LumaY deriving (Eq, Enum, Show, Bounded, Typeable)+++newtype instance Pixel Y e = PixelY e deriving (Ord, Eq)++instance Show e => Show (Pixel Y e) where+ show (PixelY g) = "<Luma:("++show g++")>"++instance Elevator e => ColorSpace Y e where+ type Components Y e = e+ promote = PixelY+ {-# INLINE promote #-}+ fromComponents = PixelY+ {-# INLINE fromComponents #-}+ toComponents (PixelY y) = y+ {-# INLINE toComponents #-}+ getPxC (PixelY y) LumaY = y+ {-# INLINE getPxC #-}+ setPxC _ LumaY y = PixelY y+ {-# INLINE setPxC #-}+ mapPxC f (PixelY y) = PixelY (f LumaY y)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelY y1) (PixelY y2) = f z y1 y2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel Y) where+ fmap f (PixelY y) = PixelY (f y)+ {-# INLINE fmap #-}+++instance Applicative (Pixel Y) where+ pure = PixelY+ {-# INLINE pure #-}+ (PixelY fy) <*> (PixelY y) = PixelY (fy y)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel Y) where+ foldr f !z (PixelY y) = f y z+ {-# INLINE foldr #-}+++instance Monad (Pixel Y) where++ return = PixelY+ {-# INLINE return #-}++ (>>=) (PixelY y) f = f y+ {-# INLINE (>>=) #-}++++instance Storable e => Storable (Pixel Y e) where++ sizeOf _ = sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ let !q = castPtr p+ y <- peek q+ return (PixelY y)+ {-# INLINE peek #-}+ poke !p (PixelY y) = let !q = castPtr p in poke q y+ {-# INLINE poke #-}+++++----------+--- YA ---+----------++-- | Luma with Alpha channel.+data YA = LumaYA -- ^ Luma+ | AlphaYA -- ^ Alpha channel+ deriving (Eq, Enum, Show, Bounded, Typeable)++data instance Pixel YA e = PixelYA !e !e deriving Eq+++instance Show e => Show (Pixel YA e) where+ show (PixelYA y a) = "<LumaAlpha:("++show y++"|"++show a++")>"+++instance Elevator e => ColorSpace YA e where+ type Components YA e = (e, e)+ promote e = PixelYA e e+ {-# INLINE promote #-}+ fromComponents (y, a) = PixelYA y a+ {-# INLINE fromComponents #-}+ toComponents (PixelYA y a) = (y, a)+ {-# INLINE toComponents #-}+ getPxC (PixelYA y _) LumaYA = y+ getPxC (PixelYA _ a) AlphaYA = a+ {-# INLINE getPxC #-}+ setPxC (PixelYA _ a) LumaYA y = PixelYA y a+ setPxC (PixelYA y _) AlphaYA a = PixelYA y a+ {-# INLINE setPxC #-}+ mapPxC f (PixelYA y a) = PixelYA (f LumaYA y) (f AlphaYA a)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelYA y1 a1) (PixelYA y2 a2) = f (f z y1 y2) a1 a2+ {-# INLINE foldlPx2 #-}+++instance Elevator e => AlphaSpace YA e where+ type Opaque YA = Y++ getAlpha (PixelYA _ a) = a+ {-# INLINE getAlpha #-}+ addAlpha !a (PixelY y) = PixelYA y a+ {-# INLINE addAlpha #-}+ dropAlpha (PixelYA y _) = PixelY y+ {-# INLINE dropAlpha #-}+++instance Functor (Pixel YA) where+ fmap f (PixelYA y a) = PixelYA (f y) (f a)+ {-# INLINE fmap #-}+++instance Applicative (Pixel YA) where+ pure !e = PixelYA e e+ {-# INLINE pure #-}+ (PixelYA fy fa) <*> (PixelYA y a) = PixelYA (fy y) (fa a)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel YA) where+ foldr f !z (PixelYA y a) = f y (f a z)+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel YA e) where++ sizeOf _ = 2 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ y <- peekElemOff q 0+ a <- peekElemOff q 1+ return (PixelYA y a)+ {-# INLINE peek #-}+ poke !p (PixelYA y a) = do+ q <- return $ castPtr p+ pokeElemOff q 0 y+ pokeElemOff q 1 a+ {-# INLINE poke #-}+
+ src/Graphics/ColorSpace/YCbCr.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Graphics.ColorSpace.YCbCr+-- Copyright : (c) Alexey Kuleshevich 2018+-- License : BSD3+-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>+-- Stability : experimental+-- Portability : non-portable+--+module Graphics.ColorSpace.YCbCr (+ YCbCr(..), YCbCrA(..), Pixel(..)+ ) where++import Control.Applicative+import Data.Foldable+import Data.Typeable (Typeable)+import Foreign.Ptr+import Foreign.Storable+import Graphics.ColorSpace.Internal+import Prelude hiding (map)++-------------+--- YCbCr ---+-------------+++-- | Color space is used to encode RGB information and is used in JPEG compression.+data YCbCr = LumaYCbCr -- ^ Luma component (commonly denoted as __Y'__)+ | CBlueYCbCr -- ^ Blue difference chroma component+ | CRedYCbCr -- ^ Red difference chroma component+ deriving (Eq, Enum, Show, Bounded, Typeable)++data instance Pixel YCbCr e = PixelYCbCr !e !e !e deriving Eq+++instance Show e => Show (Pixel YCbCr e) where+ show (PixelYCbCr y b r) = "<YCbCr:("++show y++"|"++show b++"|"++show r++")>"+++instance Elevator e => ColorSpace YCbCr e where+ type Components YCbCr e = (e, e, e)++ promote !e = PixelYCbCr e e e+ {-# INLINE promote #-}+ fromComponents !(y, b, r) = PixelYCbCr y b r+ {-# INLINE fromComponents #-}+ toComponents (PixelYCbCr y b r) = (y, b, r)+ {-# INLINE toComponents #-}+ getPxC (PixelYCbCr y _ _) LumaYCbCr = y+ getPxC (PixelYCbCr _ b _) CBlueYCbCr = b+ getPxC (PixelYCbCr _ _ r) CRedYCbCr = r+ {-# INLINE getPxC #-}+ setPxC (PixelYCbCr _ b r) LumaYCbCr y = PixelYCbCr y b r+ setPxC (PixelYCbCr y _ r) CBlueYCbCr b = PixelYCbCr y b r+ setPxC (PixelYCbCr y b _) CRedYCbCr r = PixelYCbCr y b r+ {-# INLINE setPxC #-}+ mapPxC f (PixelYCbCr y b r) = PixelYCbCr (f LumaYCbCr y) (f CBlueYCbCr b) (f CRedYCbCr r)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelYCbCr y1 b1 r1) (PixelYCbCr y2 b2 r2) =+ f (f (f z y1 y2) b1 b2) r1 r2+ {-# INLINE foldlPx2 #-}+++instance Functor (Pixel YCbCr) where+ fmap f (PixelYCbCr y b r) = PixelYCbCr (f y) (f b) (f r)+ {-# INLINE fmap #-}+++instance Applicative (Pixel YCbCr) where+ pure !e = PixelYCbCr e e e+ {-# INLINE pure #-}+ (PixelYCbCr fy fb fr) <*> (PixelYCbCr y b r) = PixelYCbCr (fy y) (fb b) (fr r)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel YCbCr) where+ foldr f !z (PixelYCbCr y b r) = f y (f b (f r z))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel YCbCr e) where++ sizeOf _ = 3 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ y <- peek q+ b <- peekElemOff q 1+ r <- peekElemOff q 2+ return (PixelYCbCr y b r)+ {-# INLINE poke #-}+ poke !p (PixelYCbCr y b r) = do+ q <- return $ castPtr p+ pokeElemOff q 0 y+ pokeElemOff q 1 b+ pokeElemOff q 2 r+ {-# INLINE peek #-}+++--------------+--- YCbCrA ---+--------------+++-- | YCbCr color space with Alpha channel.+data YCbCrA = LumaYCbCrA -- ^ Luma component (commonly denoted as __Y'__)+ | CBlueYCbCrA -- ^ Blue difference chroma component+ | CRedYCbCrA -- ^ Red difference chroma component+ | AlphaYCbCrA -- ^ Alpha component.+ deriving (Eq, Enum, Show, Bounded, Typeable)++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) = "<YCbCrA:("++show y++"|"++show b++"|"++show r++"|"++show a++")>"+++instance Elevator e => ColorSpace YCbCrA e where+ type Components YCbCrA e = (e, e, e, e)++ promote !e = PixelYCbCrA e e e e+ {-# INLINE promote #-}+ fromComponents !(y, b, r, a) = PixelYCbCrA y b r a+ {-# INLINE fromComponents #-}+ toComponents (PixelYCbCrA y b r a) = (y, b, r, a)+ {-# INLINE toComponents #-}+ getPxC (PixelYCbCrA y _ _ _) LumaYCbCrA = y+ getPxC (PixelYCbCrA _ b _ _) CBlueYCbCrA = b+ getPxC (PixelYCbCrA _ _ r _) CRedYCbCrA = r+ getPxC (PixelYCbCrA _ _ _ a) AlphaYCbCrA = a+ {-# INLINE getPxC #-}+ setPxC (PixelYCbCrA _ b r a) LumaYCbCrA y = PixelYCbCrA y b r a+ setPxC (PixelYCbCrA y _ r a) CBlueYCbCrA b = PixelYCbCrA y b r a+ setPxC (PixelYCbCrA y b _ a) CRedYCbCrA r = PixelYCbCrA y b r a+ setPxC (PixelYCbCrA y b r _) AlphaYCbCrA a = PixelYCbCrA y b r a+ {-# INLINE setPxC #-}+ mapPxC f (PixelYCbCrA y b r a) =+ PixelYCbCrA (f LumaYCbCrA y) (f CBlueYCbCrA b) (f CRedYCbCrA r) (f AlphaYCbCrA a)+ {-# INLINE mapPxC #-}+ liftPx = fmap+ {-# INLINE liftPx #-}+ liftPx2 = liftA2+ {-# INLINE liftPx2 #-}+ foldlPx = foldl'+ {-# INLINE foldlPx #-}+ foldlPx2 f !z (PixelYCbCrA y1 b1 r1 a1) (PixelYCbCrA y2 b2 r2 a2) =+ f (f (f (f z y1 y2) b1 b2) r1 r2) a1 a2+ {-# INLINE foldlPx2 #-}+++instance Elevator e => AlphaSpace YCbCrA e where+ type Opaque YCbCrA = YCbCr++ getAlpha (PixelYCbCrA _ _ _ a) = a+ {-# INLINE getAlpha #-}+ addAlpha !a (PixelYCbCr y b r) = PixelYCbCrA y b r a+ {-# INLINE addAlpha #-}+ dropAlpha (PixelYCbCrA y b r _) = PixelYCbCr y b r+ {-# INLINE dropAlpha #-}+++instance Functor (Pixel YCbCrA) where+ fmap f (PixelYCbCrA y b r a) = PixelYCbCrA (f y) (f b) (f r) (f a)+ {-# INLINE fmap #-}+++instance Applicative (Pixel YCbCrA) where+ pure !e = PixelYCbCrA e e e e+ {-# INLINE pure #-}+ (PixelYCbCrA fy fb fr fa) <*> (PixelYCbCrA y b r a) = PixelYCbCrA (fy y) (fb b) (fr r) (fa a)+ {-# INLINE (<*>) #-}+++instance Foldable (Pixel YCbCrA) where+ foldr f !z (PixelYCbCrA y b r a) = f y (f b (f r (f a z)))+ {-# INLINE foldr #-}+++instance Storable e => Storable (Pixel YCbCrA e) where++ sizeOf _ = 4 * sizeOf (undefined :: e)+ {-# INLINE sizeOf #-}+ alignment _ = alignment (undefined :: e)+ {-# INLINE alignment #-}+ peek !p = do+ q <- return $ castPtr p+ y <- peekElemOff q 0+ b <- peekElemOff q 1+ r <- peekElemOff q 2+ a <- peekElemOff q 3+ return (PixelYCbCrA y b r a)+ {-# INLINE peek #-}+ poke !p (PixelYCbCrA y b r a) = do+ q <- return $ castPtr p+ poke q y+ pokeElemOff q 1 b+ pokeElemOff q 2 r+ pokeElemOff q 3 a+ {-# INLINE poke #-}++